perm filename NCOMPL[MAC,LSP]1 blob
sn#287423 filedate 1977-06-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00112 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 **************************************************************
C00007 00003
C00011 00004
C00015 00005
C00019 00006
C00022 00007
C00023 00008
C00032 00009
C00035 00010
C00047 00011
C00051 00012
C00080 00013
C00082 00014
C00088 00015
C00091 00016
C00108 00017
C00114 00018
C00118 00019
C00122 00020
C00131 00021
C00142 00022
C00145 00023
C00148 00024
C00149 00025
C00155 00026
C00157 00027
C00161 00028
C00171 00029
C00173 00030
C00175 00031
C00181 00032
C00184 00033
C00197 00034
C00199 00035
C00203 00036
C00206 00037
C00214 00038
C00217 00039
C00219 00040
C00223 00041
C00226 00042
C00230 00043
C00233 00044
C00236 00045
C00240 00046
C00243 00047
C00245 00048
C00247 00049
C00250 00050
C00254 00051
C00259 00052
C00261 00053
C00263 00054
C00270 00055
C00274 00056
C00277 00057
C00280 00058
C00282 00059
C00285 00060
C00288 00061
C00290 00062
C00294 00063
C00297 00064
C00300 00065
C00303 00066
C00310 00067
C00312 00068
C00315 00069
C00316 00070
C00349 00071
C00350 00072
C00363 00073
C00367 00074
C00369 00075
C00373 00076
C00376 00077
C00380 00078
C00384 00079
C00387 00080
C00390 00081
C00393 00082
C00396 00083
C00404 00084
C00406 00085
C00412 00086
C00414 00087
C00417 00088
C00421 00089
C00424 00090
C00426 00091
C00429 00092
C00433 00093
C00438 00094
C00440 00095
C00442 00096
C00444 00097
C00446 00098
C00449 00099
C00451 00100
C00453 00101
C00455 00102
C00470 00103
C00473 00104
C00486 00105
C00489 00106
C00492 00107
C00496 00108
C00499 00109
C00502 00110
C00506 00111
C00514 00112
C00515 ENDMK
C⊗;
;;; **************************************************************
;;; ***** MACLISP ***** LISP COMPILER (NCOMPLR) ******************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1977 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
;;; FOLLOWING CODE MUST COME BEFORE THE DECLARE SO THAT ONLY THE
;;; IMPORTANT SYMBOLS GET ON THE COPY OF THE INITIAL OBARRAY
(COND ((STATUS FEATURE DEC10)) ;NO EXTRA OBARRAYS ON DEC10
(*PURE ;PURE-COPY THE BUCKETS OF THE INITIAL
((LAMBDA (N) ; OBARRAY COPY, IF THIS LOADING IS
(*ARRAY 'IOBARRAY 'OBARRAY NIL) ; REQUESTING PURE CONSTANTS
(DO I 0 (1+ I) (= I N)
(STORE (IOBARRAY I)
(PURCOPY (OBARRAY I)))))
(- (CADR (ARRAYDIMS 'OBARRAY)) 201)))
((*ARRAY 'IOBARRAY 'OBARRAY))) ;IN THE OTHER CASES, COPY CURRENT OBARRAY
(AND (STATUS FEATURE DEC10)
(ALLOC '(FIXNUM (2000 20000 1000) FLONUM (1000 10000 400)
BIGNUM (1000 10000 400)SYMBOL (4000 20000 .25)
ARRAY (1000 2000 100))))
(DECLARE (DO NIL ((EQ (EVAL (READ)) 'END-OF-SELF-COMPILE-FACTS)))
(COMPDECLARE))
(SETSYNTAX '/#
'MACRO
'(LAMBDA NIL (COND ((= (TYIPEEK) 43)
(TYI) ;FLUSH SECOND #
(EVAL (READ)))
(T ((LAMBDA (DATA FFVL)
(AND (SETQ FFVL (GET (CAR DATA) 'MACRO))
(SETQ DATA (FUNCALL FFVL DATA)))
DATA)
(READ) NIL)))))
(PUTPROP 'STARTER
(SUBST (COND ((STATUS FEATURE NEWIO) (CADDR (TRUENAME INFILE)))
((STATUS UREAD) (CADR (STATUS UREAD)))
('/703))
'N
'(LAMBDA (X) ''N))
'MACRO)
(AND (EQ COMPILER-STATE 'MAKLAP)
(ALLOC '(LIST (154000 170000 0.2) FIXNUM (12000 12000 0.2))))
(COMMENT DECLARATIONS FOR NCOMPLR ITSELF)
(PUTPROP
'COMPDECLARE
'(LAMBDA NIL
(SPECIAL
SLOTX LOUT1 LDLST SPLDLST ARGNO BVARS LOCVARS CONDP LMBP P2P
PROGP CFVFL DATA PRSSL CTAG VGO VGOL EXIT EFFS SYMBOLS EXLDL
P1CSQ P1LSQ P1PSQ LERSTP+1 EXITN PVR LOUT SFLG MACROLIST CL
HLAC BARFP ERRFL MAPEX MAPSB CNT GL PVRL LPRSL FASLPUSH NLNVS
P1LL VL RNL CH PROGN NULFU GOFOO SPECIAL GONE2 ATPL1
LINE DEV USR GENPREFIX GFYC GOBRKL INDICLIST LAP-INSIGNIF
ARRAYOPEN CLPROGN P1PCX P1CCX MACROS SOBARRAY INMLS ONMLS
NOARGS ARGSP COMAL UNDFUNS OPVRL MODELIST CLOSED MUZZLED
FIXSW FLOSW NFUNVARS ARITHP PROGTYPE PROGPNOB CONDTYPE
DATAERRP STSL INIT1 REGACS NUMACS REGPDL FXPDL FLPDL SQUID
ACSMODE TAKENAC1 LISPERRP COBARRAY UNSFLST PROGUNSF CONDUNSF
NLNVTHTBP CONDPNOB FFVL FASL NOLAP OLVRL ATPL PNOB MSDIR
ASSEMBLE UNFASLCOMMENTS DISOWNED TOPFN MESSIOC TTYNOTES MSDEV
INITIALIZE COMP CARCDR SWITCHLIST ROSENCEK P1LLCEK CLEANUPSPL
ARGLOC EOC-EVAL EXPR-HASH COMPILER-STATE TOPS10P CREADTABLE
LAPLL SPECVARS READ NIOP/| KTYPE PKTYP P1GFY RECOMPL
CMSGFILES OUTFILES UWRITE UREAD LINEL MAKUNBOUND QSM
P1SPECIALIZEDVS INFILE INSTACK TYO L-END-CNT)
(*FEXPR INITIALIZE *EXPR *FEXPR *LEXPR SPECIAL UNSPECIAL FIXNUM
MAKLAP NOTYPE ARRAY* SPLITFILE FLONUM REMLAP **ARRAY
CGOL EREAD)
(*LEXPR LINEL)
(FIXNUM ARGNO HLAC CNT VALAC TAKENAC1 BASE IBASE (OUTFUNCALL)
NARGS AC N M I II RSTNO BESTCNT BESTLOC NOACS P1CNT LINEL
(FRAC1)
(FRAC5) (P1TRESS) (FREENUMAC) (FREEREGAC) (FRAC) (FRACB)
(LOCINAC) (CC0) (CLLOC) (LOCINNUMAC0 NOTYPE FIXNUM)
(LOCINNUMAC NOTYPE FIXNUM) (CONVNUMLOC FIXNUM) (ZTYI)
(FREENUMAC0) (FREENUMAC1) (COMARRAY) (ARRAYACCESS)
(COMLC) (OUTFUNCALL) (COML1))
(*EXPR CARCDR COMP CC0 NARGS INIT1 UNSAFEP CLEANUPSPL NEWIO
P1GFY P1SPECIALIZEDVS)
(APPLY 'ARRAY* (SUBST NIL NIL '((NOTYPE (BOLA 6) (STGET 12) (CBA 20)
(PVIA 3 17.) (A1S1A ? 4)))))
(FIXSW T) (CLOSED NIL) (GENPREFIX /|N) (GENSYM 0) (NOARGS T)
(ARGS 'TYIPEEK NIL))
'EXPR)
(COMMENT MACRO DEFUNITIONS)
(PUTPROP 'DISPLACE
(COND ((AND (NOT (EQ COMPILER-STATE 'MAKLAP)) (NULL *PURE))
'(LAMBDA (L) ;A MASTER MACRO, WHICH CLOBBERS THE
((LAMBDA (A1 A2) ;CALL BY THE PRODUCT OF THE CALL
(RPLACA A1 (CAR A2))
(RPLACD A1 (CDR A2))
(LIST 'QUOTE A1))
(EVAL (CADR L))
(EVAL (CADDR L)))))
('(LAMBDA (L) (LIST 'QUOTE (EVAL (CADDR L))))))
'MACRO)
(DEFUN POP MACRO (X) (DISPLACE X (LIST 'SETQ (CADR X) (LIST 'CDR (CADR X)))))
(DEFUN PUSH MACRO (X) (DISPLACE X (LIST 'SETQ (CADDR X) (LIST 'CONS (CADR X) (CADDR X)))))
(DEFUN SYMBOLP MACRO (X) (DISPLACE X (SUBST (CADR X) 'X '(EQ (TYPEP X) 'SYMBOL))))
(DEFUN EQUIV MACRO (X)
(DISPLACE X (LIST 'COND
(LIST (CADR X) (CADDR X))
(LIST (LIST 'NULL (CADDR X))))))
(DEFUN KNOW-ALL-TYPES MACRO (X)
(DISPLACE X (SUBST (CADR X) 'A '(COND ((NULL A) NIL)
((MEMQ A '(FIXNUM FLONUM)))
((NOT (MEMQ NIL A)))))))
(DEFUN INITIALSLOTS MACRO (X)
(DISPLACE X ''((NIL NIL NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) NIL NIL NIL)))
(DEFUN NACS MACRO (X) (DISPLACE X ''5))
(DEFUN NUMVALAC MACRO (X) (DISPLACE X ''7))
(DEFUN NUMNACS MACRO (X) (DISPLACE X ''3))
(DEFUN NACS+1 MACRO (X) (DISPLACE X ''6))
(DEFUN /2↑N-P MACRO (X) (DISPLACE X (SUBST (CADR X) 'N '(ZEROP (BOOLE 4 N (- N))))))
(DEFUN SPECIALP MACRO (X)
(DISPLACE X (SUBST (CADR X)
'X
'(COND ((GET X 'SPECIAL))
((NULL SPECVARS) NIL)
((MEMQ X SPECVARS) T)))))
(DEFUN PDLLOCP MACRO (X) (DISPLACE X (SUBST (CADR X) 'X '(SIGNP LE X))))
(DEFUN ACLOCP MACRO (X) (DISPLACE X (SUBST (CADR X) 'X '(SIGNP G X))))
(DEFUN NUMACP MACRO (X)
(DISPLACE X ((LAMBDA (Y) (COND ((EQ (CADR X) 'ARGNO) Y) ((SUBST (CADR X) 'ARGNO Y))))
'(NOT (< ARGNO #(NUMVALAC))))))
(DEFUN FXP0 MACRO (X) (DISPLACE X ''-5000))
(DEFUN FLP0 MACRO (X) (DISPLACE X ''-10000))
(DEFUN NUMPDLP MACRO (X) (DISPLACE X (SUBST (CADR X) 'ARGNO '(NOT (> ARGNO #(FXP0))))))
(DEFUN FLPDLP MACRO (X) (DISPLACE X (SUBST (CADR X) 'ARGNO '(NOT (> ARGNO #(FLP0))))))
(DEFUN REGPDLP MACRO (X)
(DISPLACE X (SUBST (CADR X) 'ARGNO '(AND (NOT (> ARGNO 0)) (> ARGNO #(FXP0))))))
(DEFUN REGACP MACRO (X)
(DISPLACE X (SUBST (CADR X) 'ARGNO '(AND (> ARGNO 0) (< ARGNO #(NUMVALAC))))))
(DEFUN PDLAC MACRO (X)
(DISPLACE X
((LAMBDA (Y) (COND ((EQ (CADR X) 'MODE) Y) ((SUBST (CADR X) 'MODE Y))))
'(COND ((EQ MODE 'FIXNUM) 'FXP) ((NULL MODE) 'P) ('FLP)))))
(DEFUN PDLGET MACRO (X)
(DISPLACE X ((LAMBDA (Y) (COND ((EQ (CADR X) 'MODE) Y) ((SUBST (CADR X) 'MODE Y))))
'(COND ((EQ MODE 'FIXNUM) FXPDL) ((NULL MODE) REGPDL) (FLPDL)))))
(DEFUN ACSGET MACRO (X)
(DISPLACE X ((LAMBDA (Y) (COND ((EQ (CADR X) 'MODE) Y) ((SUBST (CADR X) 'MODE Y))))
'(COND (MODE NUMACS) (REGACS)))))
(DEFUN ACSSLOT MACRO (X)
(DISPLACE X (SUBST (CADR X) 'N '(COND ((= N #(NUMVALAC)) NUMACS)
((= N ##(1+ #(NUMVALAC))) (CDR NUMACS))
(T (CDDR NUMACS))))))
(DEFUN ACSMODESLOT MACRO (X)
(DISPLACE X (SUBST (CADR X) 'N '(COND ((= N #(NUMVALAC)) ACSMODE)
((= N ##(1+ #(NUMVALAC))) (CDR ACSMODE))
(T (CDDR ACSMODE))))))
(DEFUN NACSGET MACRO (X)
(DISPLACE X ((LAMBDA (Y) (COND ((EQ (CADR X) 'MODE) Y) ((SUBST (CADR X) 'MODE Y))))
'(COND ((NULL MODE) (1+ #(NACS))) ((1+ #(NUMNACS)))))))
(DEFUN OUTFS MACRO (X)
(DISPLACE X (CONS (COND ((NULL (CDDDDR X)) 'OUT3FIELDS)
((NULL (CDR (CDDDDR X))) 'OUT4FIELDS)
(T 'OUT5FIELDS))
(REVERSE (CDR X)))))
(DEFUN ILOCREG MACRO (X) (DISPLACE X (LIST 'ILOCMODE (CADR X) (CADDR X) ''(NIL FIXNUM FLONUM))))
(DEFUN ILOCNUM MACRO (X) (DISPLACE X (LIST 'ILOCMODE (CADR X) (CADDR X) ''(FIXNUM FLONUM))))
(DEFUN ILOCF MACRO (X) (DISPLACE X (CONS 'ILOCMODE (CONS (CADR X) '('FRACF '(NIL FIXNUM FLONUM))))))
(DEFUN ILOCN MACRO (X) (DISPLACE X (CONS 'ILOCMODE (CONS (CADR X) '('ARGNO '(NIL FIXNUM FLONUM))))))
(DEFUN FREACB MACRO (X) (DISPLACE X '(FREEREGAC 'FRACB)))
(DEFUN FREAC MACRO (X) (DISPLACE X '(FREEREGAC 'FRAC)))
(DEFUN WORKITOUT MACRO (Y) ;NOTICE HOW "X" IS USED ALSO
(SETQ Y (LIST (LIST 'QUOTE (CADR Y)) (EVAL (CADDR Y)) (EVAL (CADDDR Y))))
(SETQ Y (CONS (SUBST (CADDR X) 'MSG '(FUNCTION (LAMBDA () (PRINC 'MSG)))) Y))
(DISPLACE X (LIST 'QUOTE (CONS 'MSOUT (CONS (CADR X) Y)))))
(DEFUN BARF MACRO (X) (WORKITOUT BARF (CADDDR X) (CAR (CDDDDR X))))
(DEFUN DBARF MACRO (X) (WORKITOUT DATA (CADDDR X) (CAR (CDDDDR X))))
(DEFUN WARN MACRO (X) (WORKITOUT WARN (CADDDR X) (CAR (CDDDDR X))))
(DEFUN PDERR MACRO (X) (WORKITOUT ERRFL 4 6))
(DEFUN STB MACRO (X)
(DISPLACE X (DO ((N (EVAL (CADR X)) (1- N))
(DATA (SUBST (NUMVALAC) 'AC '((TDZA N N)
(MOVEI N 'T)
(SKIPE 0 N)
(MOVNI AC N)
(MOVEI N 'NIL))))
(Z))
((ZEROP N) (SUBST (CONS NIL Z) 'Z '(FILLARRAY 'BOLA 'Z)))
#(PUSH (SUBST N 'N DATA) Z))))
(DEFUN STA MACRO (X)
(DISPLACE
X
(SUBST ((LAMBDA (NN)
(DO ((AC (+ NN (EVAL (CADDR X)) -1) (1- AC)) (Z))
((< AC NN) Z)
(SETQ Z (NCONC (MAPCAR '(LAMBDA (Y) (LIST (CAR Y) AC (CADR Y)))
'((ADDI 1) (SUBI 1) (FADRI 201400) (FSBRI 201400)))
Z))))
(EVAL (CADR X)))
'Z
'(FILLARRAY 'A1S1A 'Z))))
(DEFUN STP MACRO (X)
(DISPLACE
X
(PROG (Z 8NILS NPUSH 0PUSH)
(SETQ NPUSH (EVAL (CADR X)) 0PUSH (EVAL (CADDR X)))
(DO N (- NPUSH 0PUSH) (1- N) (ZEROP N) #(PUSH NIL 8NILS)) ;ENOUGH NILS TO FILL OUT DIFFERENCE
(SETQ Z 8NILS) ;BETWEEN MAX NUMBER FOR NPUSH
(DO N 0PUSH (1- N) (= N 2) ;AND FOR 0PUSH AND 0*0PUSH
#(PUSH (SUBST (MINUS N) 'N '(JSP T (0*0PUSH N))) Z))
(SETQ Z (APPEND 8NILS (LIST 0PUSH) '((PUSH FLP (% 0.0)) NIL) Z))
(DO N 0PUSH (1- N) (= N 2)
#(PUSH (SUBST (MINUS N) 'N '(JSP T (0PUSH N))) Z))
(SETQ Z (APPEND (LIST 0PUSH) '((PUSH FXP (% 0)) NIL) Z))
(DO N NPUSH (1- N) (= N 2)
#(PUSH (SUBST (MINUS N) 'N '(JSP T (NPUSH N))) Z))
(SETQ Z (APPEND (LIST NPUSH) '((PUSH P (% 0 0 'NIL)) NIL) Z))
(RETURN (SUBST Z 'Z '(FILLARRAY 'PVIA 'Z))))))
(DEFUN STST MACRO (X)
(DISPLACE X (DO ((N (EVAL (CADR X)) (1- N))
(Z))
((ZEROP N) (SUBST (CONS NIL Z) 'Z '(FILLARRAY 'STGET 'Z)))
#(PUSH (SUBST N 'N '(0 ST N)) Z))))
'END-OF-SELF-COMPILE-FACTS
(COMMENT SOME LOAD TIME HACS)
(AND (NOT (STATUS FEATURE SAIL)) (PUTPROP 'EREAD (GET 'UREAD 'FSUBR) 'FSUBR))
(AND *PURE
(SETQ GOBRKL PUTPROP
PUTPROP (APPEND '(STATUS SSTATUS INST INSTN IMMED CARCDR NUMBERP ARITHP NOTNUMP
CONTAGIOUS COMMU ACS CONV MINUS BOTH FLOATI P1BOOL1ABLE)
PUTPROP)))
(SETSYNTAX '/& 'MACRO '(LAMBDA NIL ((LAMBDA (OBARRAY READTABLE) (READ)) COBARRAY CREADTABLE)))
(SETQ INIT1 '##(COND ((EQ COMPILER-STATE 'MAKLAP) (STARTER))
('INTERPRETER)))
(AND (NOT (EQ INIT1 'INTERPRETER))
(PROGN (SETQ NORET T) (GETSP 70000) (SSTATUS LOSEF 7)))
(COMMENT INITIALIZING FUNCTIONS)
(DEFUN INITIALIZE FEXPR (L)
(SSTATUS FEATURE NCOMPLR)
(AND (GETL 'REMLAP '(FSUBR FEXPR))
(NOT (MEMQ 'LAP L))
(REMLAP))
(SETQ NIOP/| (STATUS FEATURE NEWIO))
(COND ((STATUS FEATURE DEC10)
(SETQ TOPS10P T CREADTABLE READTABLE COBARRAY OBARRAY))
(T (SETQ TOPS10P NIL CREADTABLE (*ARRAY NIL 'READTABLE T))
(SETQ OBARRAY (SETQ COBARRAY (*ARRAY NIL 'OBARRAY 'IOBARRAY)))
(MAPC 'INTERN
'(COBARRAY SOBARRAY CREADTABLE MAKLAP COMPILE
ARGSP UNDFUNS INIT1 COUTPUT ONMLS MSDEV MSDIR
DECLARE DISOWNED TTYNOTES FASL NOLAP NOARGS
SPECIAL UNSPECIAL *EXPR *LEXPR *FEXPR ARRAYOPEN
ASSEMBLE SYMBOLS MACROS MAPEX UNFASLCOMMENTS
MESSIOC GENPREFIX SPLITFILE NFUNVARS ARRAY*
NOTYPE CLOSED MUZZLED FIXSW FLOSW NUMVAR NUMFUN
COMPILER-STATE TOPLEVEL GOFOO EOC-EVAL RECOMPL
EXPR-HASH CMSGFILES SQUID))
(AND (NOT NIOP/|)
(MAPC 'INTERN
'(ECHOFILES MSGFILES INFILE INSTACK OUTFILES
IO-LOSSAGE CLI-MESSAGE OPEN LINEL READLINE
ENDPAGEFN EOFFN PAGEL CHARPOS LINENUM PAGENUM
RUBOUT FILEPOS INCLUDE IN INPUSH OUT TRUENAME
SHORTNAMESTRING NAMESTRING NAMELIST DEFAULTF
PROBEF LOAD FORCE-OUTPUT CLEAR-OUTPUT
CLEAR-INPUT CLOSE DELETEF RENAMEF MERGEF)))))
(SETQ OBARRAY (SETQ SOBARRAY (GET 'OBARRAY 'ARRAY)))
((LAMBDA (Z PROP)
(AND (CDR L) (SETQ PROP (LSUB PROP (CDR L))))
(MAPATOMS '(LAMBDA (Y)
(LREMPROP Y PROP)
(AND (NOT (SYSP Y)) (ARGS Y NIL))
(AND (GET Y 'VALUE)
(NOT (MEMQ Y '(T NIL)))
(SETQ DATA Y)
(MEMQ 'VALUE (STATUS SYSTEM DATA))
#(PUSH Y Z)))
COBARRAY)
(APPLY 'SPECIAL Z))
NIL
'(MACRO SPECIAL *EXPR *FEXPR *LEXPR NUMVAR NUMFUN *ARRAY OHOME))
(AND (STATUS FEATURE FASLAP) (FASLINIT))
(MAPC '(LAMBDA (X) (SET X (COPYSYMBOL X NIL)))
'(PROGN GOFOO NULFU COMP CARCDR ARGLOC SQUID MAKUNBOUND))
(PUTPROP SQUID '(LAMBDA (GL) (LIST 'QUOTE GL)) 'MACRO)
(SETQ QSM (LIST (LIST 'QUOTE (LIST SQUID MAKUNBOUND))))
(SETQ STSL (LIST (STATUS STATUS) (STATUS SSTATUS)))
(SETQ ARGLOC (LIST ARGLOC) CLPROGN (LIST PROGN) LERSTP+1 13.
MACROLIST '((DO . DOEXPANDER)) SPECIAL NIL SYMBOLS NIL
MSDEV 'DSK SPECVARS NIL GENPREFIX '(/| G) GFYC 0 BARFP T
MACROS NIL UNDFUNS NIL P1LLCEK NIL LAPLL NIL ROSENCEK NIL
CLOSED NIL MUZZLED NIL FIXSW NIL FLOSW NIL BASE 8. IBASE 8.
DATAERRP T LISPERRP T *NOPOINT NIL RNL NIL CFVFL NIL CL NIL
MAPEX NIL PRINLEVEL NIL PRINLENGTH NIL FASLPUSH NIL
P1GFY NIL RECOMPL NIL CMSGFILES NIL
ARGSP NIL NOARGS NIL EOC-EVAL NIL COMPILER-STATE 'TOPLEVEL
FASL NIL NOLAP NIL ASSEMBLE NIL UNFASLCOMMENTS NIL FFVL NIL
TTYNOTES NIL INITIALIZE NIL MESSIOC NIL TOPFN NIL ONMLS NIL
MSDIR NIL READ NIL INIT1 #(STARTER) CLEANUPSPL 0 EXPR-HASH NIL
DISOWNED NIL NFUNVARS NIL ARRAYOPEN T LAP-INSIGNIF NIL
MAPSB (NCONC (MAPCAR 'LIST '(VL EXIT USR PVR STSL)) (LIST (CONS 'GOFOO GOFOO)))
INDICLIST '((EXPR . SUBR) (FEXPR . FSUBR) (LEXPR . LSUBR))
COMAL (SUBST NIL NIL '((NIL . NIL) (FIXNUM . FIXNUM) (FLONUM . FLONUM) (T))) )
(RPLACD (CAR COMAL) (CAR COMAL)) ;SETQ UP INFINITE TYPE LISTS FOR COMARITH
(RPLACD (CADR COMAL) (CADR COMAL))
(RPLACD (CADDR COMAL) (CADDR COMAL))
(ARRAY BOLA NIL ##(1+ (NACS))) ;TDZA N,N ? MOVEI N,'T ? SKIPE 0 N
#(STB (NACS)) ;USED WHEN COMPILING LOGIC-CONTROL PREDICATES
(ARRAY STGET NIL ##(+ 1 (NUMVALAC) (NUMNACS)))
#(STST (+ (NUMVALAC) (NUMNACS)))
(ARRAY CBA NIL 20) ;COMPILE-BOOLE-ARRAY
(FILLARRAY 'CBA '((SETZ) (AND) (ANDCA) (SETA) (ANDCM) (SETM) (XOR) (IOR) (ANDCB)
(EQV) (SETCM) (ORCA) (SETCA) (ORCM) (ORCB) (SETO)))
(ARRAY A1S1A NIL #(NUMNACS) 4) ;ADD1-SUB1-ARRAY FOR INSTRUCTIONS
#(STA (NUMVALAC) (NUMNACS))
(ARRAY PVIA NIL 3 17.) ;PDL-VARIABLE-INITIALIZATION-ARRAY
#(STP 16. 8.) ;FIRST NUM IS MAX N FOR (JSP T (NPUSH -N))
;SECOND IS MAX FOR (JSP T (0PUSH -N)) AND 0*0PUSH
;SOME KNOWN DECLARATIONS
(FIXNUM (LENGTH) (RANDOM) (EXAMINE FIXNUM) (LISTEN) (RUNTIME)
(GETCHARN NOTYPE FIXNUM) (FLATSIZE) (FLATC) (LSH) (ROT) (BOOLE) (IFIX)
(↑ FIXNUM FIXNUM) (SXHASH) (TYIPEEK) (TYI) (HAULONG))
(MAPC '(LAMBDA (X) (AND #(SPECIALP X) (APPLY 'FIXNUM (LIST X))))
'(BASE IBASE CHRCT LINEL BPORG BPEND TTY))
(FLONUM (SIN) (COS) (SQRT) (LOG) (EXP) (ATAN) (TIME) (↑$ FLONUM FIXNUM) (FSC) (FLOAT))
(NOTYPE (GETCHAR NOTYPE FIXNUM) (CXR FIXNUM) (DEPOSIT FIXNUM))
(APPLY '*EXPR (LIST PROGN))
;DECLARATIONS FOR FUNCTIONS NOT LIKELY TO BE IN CORE WITH COMPLR
(*EXPR GETMIDASOP SPRINTER SORT SORTCAR)
(MAPC 'ARGS '(GETMIDASOP SPRINTER SORT SORTCAR) '((NIL . 1) (NIL . 1) (NIL . 2) (NIL . 2)))
(*FEXPR GRIND GRIND0 GRINDEF INDEX LAP TRACE)
(ARRAY* (NOTYPE (OBARRAY 1200) (READTABLE 420)))
(NEWIO (COND (NIOP/| (*EXPR LOADARRAYS DUMPARRAYS)
(ARGS 'DUMPARRAYS '(NIL . 2))
(ARGS 'LOADARRAYS '(NIL . 1))
(SSTATUS TTYINT '/≡ 'INIT3)
T)
(T (SSTATUS INTER 16. 'INIT3) NIL)))
(GCTWA))
(DEFUN INIT2 NIL ;STARTS UP MAKLAP FROM ↑↑
(SETQ ERRLIST '((INIT1)))
(SSTATUS TOPLEVEL NIL)
(INIT1)
(NOINTERRUPT NIL)
(MAKLAP))
(DEFUN INIT3 N
(SETQ ERRLIST NIL N (COND (NIOP/| (ARG 2)) (36)))
(SSTATUS TOPLEVEL '(INIT2))
(DO NIL ((OR (= (LISTEN) 0) (= (TYI) N))))
(↑G))
(DEFUN CDUMP N (SETQ ERRLIST NIL)
(SSTATUS TOPLEVEL '(INIT0))
(GC)
(COND ((ZEROP N) (SUSPEND)) ((SUSPEND (ARG 1)))))
(DEFUN INIT0 () ;INITIAL TOP-LEVEL LOOP
(SETQ ERRLIST '((INIT1)))
(SSTATUS TOPLEVEL NIL)
((LAMBDA (FL FILE OBARRAY READTABLE)
(AND (COND ((APPLY 'UPROBE FILE) (APPLY 'EREAD FILE) T)
(TOPS10P NIL)
((APPLY 'UPROBE (SETQ FILE (CONS (CADR FL) '(COMPLR DSK /(INIT/)))))
(APPLY 'EREAD (CONS (CADR FL) '(COMPLR DSK /(INIT/))))
T))
(PRINC '|LOADING (INIT) FILE FOR |)
(PRINC (CADR FL))
(COND (NIOP/|
(AND (NULL (ERRSET (LOAD FILE) NIL))
(PRINC '| ERRORS DURING LOADING|)))
(T (DO ((G) (↑Q T) (FL))
((NULL ↑Q) (AND FL (PRINC '| ERRORS DURING LOADING|)))
(COND ((EQ (SETQ G (READ GOFOO)) GOFOO) (SETQ ↑Q NIL))
((ATOM (ERRSET (EVAL G))) (SETQ FL T)))))))
(APPLY 'CRUNIT FL))
(APPLY 'CRUNIT (LIST 'DSK (STATUS UDIR)))
(COND (TOPS10P '(COMPLR INI)) (T '(COMPLR /(INIT/))))
COBARRAY
CREADTABLE)
(AND (SETQ DATA (STATUS JCL))
(ERRSET (PROG (TEM)
A (AND (< (GETCHARN (CAR DATA) 1) 33)
#(POP DATA)
(GO A))
(SETQ LINE (LIST 105105))
B (SETQ TEM (GETCHARN (CAR DATA) 1))
#(PUSH (COND ((AND (< TEM 173) (> TEM 140)) (- TEM 40))
(TEM))
LINE)
(AND #(POP DATA) (GO B))
C (AND (< (CAR LINE) 33) #(POP LINE) (GO C))
(APPLY 'MAKLAP LINE))
NIL))
(INIT1)
(MAKLAP))
(DEFUN INIT1 () ;PRINCS VERSION NUMBER
(SETQ ↑W (SETQ ↑R (SETQ ↑Q NIL)))
(PRINC '##(MAKNAM (NCONC (EXPLODEC '|/
LISP COMPILER |)
(EXPLODEC #(STARTER))
(EXPLODEC '| [BY |)
(EXPLODEC INIT1)
(EXPLODEC '|] |))))
(COND (NIOP/| (PRINC '|IN NEWIO |))
(T (PRINC '|IN OLDIO |)))
NIL)
(COMMENT TOPLEVEL COMPILE)
(DEFUN COMPILE (NAME-ARG FLAG EXP RNL P1GFY)
(PROG (LOUT LOUT1 ATPL ATPL1 P1CNT LOCVARS CNT LSUBRF FL BVARS
VL EFFS EXLDL P1LL CONDP LMBP P1CSQ P1LSQ CTAG HLAC SFLG
PROGP P1PSQ GONE2 GOBRKL NLNVS AL NAME LDLST SPLDLST P2P
SPFL ARGNO PVRL OPVRL LPRSL VGOL GL PRSSL PNOB DPL
KTYPE PKTYP MODELIST ARITHP REGACS NUMACS ACSMODE REGPDL
FXPDL FLPDL OLVRL SPECVARS TAKENAC1 UNSFLST PROGUNSF
CONDUNSF NLNVTHTBP ERRFL ROSENCEK P1LLCEK *NOPOINT NARGS
MARR-LOSS NSYSFUNP P1SPECIALIZEDVS L-END-CNT)
(SETQ CNT 1 NSYSFUNP T)
(COND ((ATOM NAME-ARG) (SETQ NAME NAME-ARG NAME-ARG NIL))
(T (SETQ NAME (CAR NAME-ARG))))
(COND ((NOT P1GFY)
(GENSYM 0)
(SETQ TOPFN NAME)
(AND (SYSP NAME)
(PROG2 (ARGS NAME (SETQ NSYSFUNP NIL)) T)
(WARN NAME |REDEFINING SYSTEM FUNCTION|))))
(COND ((NULL (EQ (CAR EXP) 'LAMBDA)) (DBARF EXP |NO FUNCTION| 4 6))
((AND (CADR EXP) (ATOM (CADR EXP)))
(AND (OR (GETL NAME '(*EXPR *FEXPR))
(NOT (MEMQ FLAG '(EXPR LEXPR))))
(WRNTYP NAME))
(ARGS NAME NIL)
(PUTPROP NAME T '*LEXPR)
(SETQ LSUBRF (SETQ FLAG 'LEXPR))
(SETQ EXP (CONS (CAR EXP) (CONS (LIST (CADR EXP)) (CDDR EXP))))))
(COND (LSUBRF)
((> (SETQ NARGS (LENGTH (CADR EXP))) #(NACS))
(SETQ LSUBRF 'LSUBR FLAG 'LEXPR) ;CONVERT LONG EXPR TO LSUBR
(COND ((NOT P1GFY)
(AND NSYSFUNP (ARGS NAME (CONS NARGS NARGS)))
(AND (NOT NOARGS)
(OR (NOT ARGSP)
(FUNCALL ARGSP NAME))
(SETQ AL (CONS NARGS NARGS)))))
(LREMPROP NAME '(*EXPR *FEXPR))
(PUTPROP NAME T '*LEXPR))
((COND ((EQ FLAG 'EXPR)
(COND ((NOT P1GFY)
(AND NSYSFUNP (CKARGS NAME NARGS))
(AND (NOT NOARGS)
(OR (NOT ARGSP) (FUNCALL ARGSP NAME))
(SETQ AL (CONS NIL NARGS)))))
(SETQ FL '*EXPR)
T)
((EQ FLAG 'FEXPR)
(REMPROP NAME 'ARGS)
(SETQ FL '*FEXPR)
T))
(AND (SETQ SPFL (GETL NAME '(*EXPR *FEXPR *LEXPR)))
(NOT (EQ FL (CAR SPFL)))
(WRNTYP NAME))
(PUTPROP NAME T FL))
((EQ FLAG 'LEXPR) (SETQ LSUBRF 'LSUBR FLAG 'LEXPR)))
(SETQ P1LL (CADR EXP) EXP (CDDR EXP))
(COND ((EQ (CAAR EXP) 'DECLARE) (LCLDECLARE EXP) (SETQ EXP (CDR EXP))))
(SETQ P1LL (P1LMBIFY P1LL
NAME
(SETQ KTYPE (GET NAME 'NUMFUN))))
(AND KTYPE (SETQ KTYPE (CADR KTYPE)))
(DO X P1LL (CDR X) (NULL X)
(AND (NOT #(SPECIALP (CAR X)))
(NULL (VARMODE (CAR X)))
(SETQ UNSFLST (CONS (CAR X) UNSFLST))))
(SETQ EXP (P1GLM P1LL EXP))
(SETQ UNSFLST (LSUB UNSFLST (P1SPECIALIZEDVS)))
(UUVP P1LL 'P1LL 'LAMBDA)
(AND ERRFL (ERR 'DATA))
(AND NLNVS (NLNVASG (MAPCAR 'CAR NLNVS)))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) NIL 'OHOME)) LOCVARS)
(SETQ LOUT (LIST 'LAP NAME (COND ((NULL NAME-ARG) (CDR (ASSQ FLAG INDICLIST)))
((NULL (CDDR NAME-ARG)) (CADR NAME-ARG))
((CADDR NAME-ARG)))))
(SETQ LOUT1 (SETQ ATPL1 'FOO)) ;ATPL IS STILL NIL
(AND (NOT (= BASE 8.))
((LAMBDA (B BASE)
(OUTPUT (SUBST B 'BASE '(EVAL (SETQ IBASE BASE))))
(PROG2 (OUTPUT 'FOO) (OUTPUT 'FOO))
(SETQ *NOPOINT NIL))
BASE 8.))
(AND AL #(OUTFS 'ARGS NAME AL))
(COND (SYMBOLS (OUTPUT '(SYMBOLS T))
(COND ((> (FLATC NAME) 5) (OUTPUT (GENSYM))))))
(AND KTYPE
(OUTPUT (COND ((EQ LSUBRF 'LEXPR)
(COND ((EQ KTYPE 'FIXNUM) '(JSP D (*LCALL -1)))
('(JSP D (*LCALL -2)))))
((EQ LSUBRF 'LSUBR)
(OUTPUT (COND ((EQ KTYPE 'FIXNUM) '(SKIPA T (% 0 0 FIX1A)))
('(SKIPA T (% 0 0 FLCONS)))))
(SETQ MARR-LOSS (LIST (GENSYM)))
'(MOVEI T 0))
((EQ KTYPE 'FIXNUM) '(PUSH P (% 0 0 FIX1)))
('(PUSH P (% 0 0 FLOAT1))))))
(SETQ HLAC (SETQ LPRSL (SETQ TAKENAC1 0)))
(SETQ P1CNT CNT CNT 1 BVARS NIL PNOB NIL P2P T)
(SETQ AL #(INITIALSLOTS))
(SETQ REGACS (APPEND (CAR AL) NIL))
(SETQ NUMACS (APPEND (CADR AL) NIL))
(SETQ ACSMODE (APPEND NUMACS NIL))
(SETQ REGPDL NIL FXPDL NIL FLPDL NIL)
(SETQ ARGNO (COND (KTYPE #(NUMVALAC)) (1)))
(COND ((EQ LSUBRF 'LEXPR) (OUTPUT '(JSP D *LCALL)))
((EQ LSUBRF 'LSUBR)
(DO I NARGS (1- I) (ZEROP I) #(PUSH NIL REGPDL))
(COND (MARR-LOSS
(SETQ FXPDL (LIST MARR-LOSS))
#(PUSH MARR-LOSS LDLST)
(OUTPUT '(PUSH FXP T)))))
((AND (EQ FLAG 'FEXPR) (CDAR (CDDDDR EXP)))
(OUTPUT '(EXCH 1 2))
(OUTPUT '(MOVE TT 17))
(OUTPUT '(JSP T FIX1A))
(OUTPUT '(EXCH 1 2))))
(SETQ FL (CDDDDR EXP))
(CNPUSH (APPEND NLNVTHTBP (CAR (CDDDDR FL))) NIL)
(SETQ BVARS (APPEND (CAR FL) BVARS) ;LSUBRF = +1 => SUBR
LSUBRF (COND ((EQ LSUBRF 'LSUBR) -1) (+1))) ;LSUBRF = -1 => LSUBR
(SETQ SPFL SFLG)
(DO ((AC (LSH (1+ LSUBRF) -1) (+ AC LSUBRF))
(X (COND ((< LSUBRF 0) (REVERSE (CAR FL))) ((CAR FL))) (CDR X))
(MODE))
((NULL X))
(COND (#(SPECIALP (CAR X))
(COND ((NULL SPFL)
(SETQ SPFL T)
(CPUSH ##(+ (NUMVALAC) 2))
(OUTPUT '(JSP T SPECBIND))))
(OSPB AC (CAR X))))
(COND ((> LSUBRF 0) (CONT AC (LIST (CAR X)))) ;SUBR TYPE
((NOT #(SPECIALP (CAR X)))
(CONT AC (COND ((SETQ MODE (VARMODE (CAR X)))
#(PUSH (CONS AC (CONS (LIST (CAR X)) MODE)) DPL)
NIL)
(T (LIST (CAR X))))))))
(MAPC '(LAMBDA (L) (OPUSH (CAR L) (CADR L) (CDDR L))) DPL)
(SETQ EXP (CADDDR (CDDR EXP)))
(COND (DPL (SETQ SFLG NIL)) ;DPL IS THE DELAYED-PUSHES LIST
((SETQ SPFL (PROGHACSET SPFL EXP))))
(LOADAC (COMP EXP) ARGNO T) ;SINCE PNOB HAS BEEN NIL, THIS SHOULD
;NOT CAUSE A PDLNMK
(AND KTYPE
(SETQ FL (GETMODE0 ARGNO T NIL))
(NOT (EQ KTYPE FL))
(WARN NAME |THIS FUNCITON WAS DECLARED NUMERICAL,/
BUT THE RESULTANT TYPE IS INCORRECT|))
(COND (MARR-LOSS
(OUT1 'SKIPE 'T (ILOC1 NIL MARR-LOSS 'FIXNUM))
(OUTPUT '(JSP T 0 T))
(OUTPUT 'FOO)
(REMOVE MARR-LOSS)))
(SETQ FL
(COND (SPFL '(JRST 0 UNBIND))
((AND (NOT (OR FXPDL FLPDL))
(NOT ATPL))
(COND ((AND (SETQ AL (ASSOC (CAR LOUT)
'((PUSHJ . JRST) (NCALL . NJCALL)
(CALL . JCALL) (NCALLF . NJCALF)
(CALLF . JCALLF))))
(COND ((OR (NULL (CDDDR LOUT))
(NOT (MEMQ '@ LOUT))
(NOT (NUMBERP (CADDDR LOUT)))))
((ZEROP (CADDDR LOUT))
(NOT (EQ (CADR (CDDDR LOUT)) 'P)))
((NOT #(PDLLOCP (CADDDR LOUT))))))
(SETQ AL (CONS (CDR AL)
(COND ((EQ (CDR AL) 'JRST) (CONS 0 (CDDR LOUT)))
((CDR LOUT)))))
(SETQ LOUT (SETQ ATPL 'FOO))
AL)
((AND (EQ (CAR LOUT) 'JSP) (EQUAL LOUT '(JSP T PDLNMK)))
(SETQ LOUT (SETQ ATPL 'FOO))
'(JRST 0 PDLNKJ))
(T '(POPJ P))))
(T '(POPJ P))))
(CONT ARGNO '(NIL . TAKEN))
(RESTORE #(INITIALSLOTS))
(OUTPUT FL)
(MAPC 'OUTG VGOL)
(COND (LDLST (BARF LDLST |LEFT ON LDLST|)))
(AND SYMBOLS (NOT (EQ SYMBOLS T)) (OUTPUT '(SYMBOLS T)))
(OUTPUT NIL) (OUTPUT NIL) (OUTPUT NIL)
(COND ((NOT FASLPUSH) (COUTPUT GOFOO) (COUTPUT GOFOO)))
(GCTWA)
(COND ((NOT (= CNT P1CNT))
(BARF (LIST P1CNT CNT) |UNEQUAL COUNT|)))
(RETURN NAME)))
(COMMENT )
;;; RESULTS FROM THE "COMP" TYPE FUNCTIONS CAN BE
;;; NIL IF COMPUTING FOR EFFECTS ONLY; OTHERWISE, IS
;;; (QUOTE MUMBLE)
;;; (VAR . CNT)
;;; (G0005 . NIL)
;;; WHERE G0005 IS EITHER 1) THE INTERNAL NAME OF SOME COMPUTATIONAL RESULT, OR
;;; 2) A CARCDR'ING, LIKE 1) ABOVE, BUT WHICH MAY BE DELAYED
(DEFUN COMP (X) ((LAMBDA (EFFS) (COMP0 X)) NIL)) ;FOR VALUE
(DEFUN COMPE (X) ((LAMBDA (EFFS PNOB) (COMP0 X)) T T)) ;FOR EFFECTS
(DEFUN COMP1 (X) (COMPW X NIL 1)) ;FOR VALUE, INTO ACCUMULATOR 1
(DEFUN COMPW (X EFFS ARGNO) (COMP0 X)) ;CAN SPECIFY EFFECTS AND ACCUMULATOR NUMBER
(DEFUN COMPR (X MODE OEFFS OPNOB) ;THIS SEEMS TO BE USEFUL IN SEVERAL PLACES
(COND (MODE (COMPW X NIL (FREENUMAC)))
(T ((LAMBDA (EFFS PNOB ARGNO) (COMP0 X))
NIL
OPNOB
(COND (OEFFS 1)
((NOT #(NUMACP ARGNO)) ARGNO)
(#(FREAC)))))))
(DEFUN COMP0 (X) ;THE BASIC "CHOMP"
((LAMBDA (Y MODE)
(COND ((ATOM X) ;"CHOMPING" A VARIABLE
(SETQ CNT (ADD1 CNT))
(COND ((NULL EFFS)
(SETQ Y (CONS X CNT))
(COND (#(SPECIALP X) #(PUSH Y SPLDLST))
((ILOC0 Y (SETQ MODE (VARMODE X))))
((AND MODE (ILOC0 Y NIL)))
((COND ((OR (MEMQ X PVRL) (MEMQ X OPVRL))
(AND MODE (PDERR X |UNINITIALIZED NUMBER VARIABLE|))
T)
((MEMQ X OLVRL)))
(SETQ Y (COND ((NULL MODE) '(QUOTE NIL))
((EQ MODE 'FIXNUM) '(QUOTE 0))
(T '(QUOTE 0.0)))))
((BARF Y |WHAT KIND OF VARIABLE IS THIS - COMP0|))))))
((EQ (CAR X) 'QUOTE) (SETQ Y X)) ;"CHOMPING" SOMETHING QUOTED
((AND (NOT (ATOM (CAR X))) (EQ (CAAR X) CARCDR)) ;"CHOMPING" A CARCDRING
(COND (EFFS (COMP0 (CADR X)))
(T (SETQ Y (COND ((NOT (ATOM (CADR X)))
(COND (#(NUMACP ARGNO) (COMP1 (CADR X)))
((COMP0 (CADR X)))))
(#(SPECIALP (CADR X))
(CAR #(PUSH (CONS (CADR X) (SETQ CNT (ADD1 CNT)))
LDLST)))
(T (COMP0 (CADR X)))))
#(PUSH (XCONS (CONS (CDAR X) Y)
(SETQ Y (GENSYM)))
SPLDLST)
(SETQ Y (LIST Y)))))
(T (SETQ Y (COMPFORM X))
(AND (NULL EFFS) PNOB (UNSAFEP X) (SETQ UNSFLST (ADD (CAR Y) UNSFLST)))))
(COND ((NULL EFFS) #(PUSH Y LDLST) Y)))
NIL NIL))
(COMMENT PHASE2 COMPILATION FUNCTIONS)
(DEFUN COMPFORM (F)
(PROG (X Y Z FNARGS VALAC NARGS TEM T1 CCSLD ARRAYP)
(SETQ X (CAR F) Y (CDR F) VALAC 1)
A (AND (SETQ T1 (NOT (ATOM X)))
; COMPILE FOR NON-ATOMIC FUNCTION
(COND ((AND (EQ (CAR X) 'FSUBR) (ATOM (CDR X)))
(AND (NOT (GET (CDR X) 'ACS)) (CSLD (SETQ CCSLD T) T NIL))
(LOADAC (COMPW Y NIL 1) 1 NIL)
(SETQ X (CDR X))
(GO FX1))
((EQ (CAR X) 'LAMBDA) (RETURN (COMLAM X Y)))
((EQ (CAR X) '*MAP)
(CSLD (SETQ CCSLD (CADR X)) T NIL)
(COND ((NOT (EQ (CADDR X) '*MAP))
(COMLC (CADDR X) Y NIL)
(GO CALLX)))
(LOADACS ((LAMBDA (EFFS ARGNO)
(LIST (COMP0 (CAR Y))
(COMP0 (PROG2 (SETQ ARGNO 1)
(CADR Y)))))
NIL 2)
2
NIL)
(CLEARACS0 T)
#(OUTFS 'PUSHJ 'P (CDDR X))
(GO CALLX))
((EQ (CAR X) 'RPLACD) (RETURN (COMRPLAC 'RPLACD Y T)))
((EQ (CAR X) 'MAKNUM)
((LAMBDA (ARGNO EFFS PNOB)
(SETQ Z (COMP0 (CAR Y)) Y ARGNO))
(COND (#(NUMACP ARGNO)
(SETQ TEM (COND ((NOT (DVP ARGNO)) ARGNO)
((NOT (ZEROP (SETQ TEM (FREENUMAC1)))) TEM)
(#(NUMVALAC))))
(FRAC5))
(T (SETQ TEM NIL) 1))
NIL
NIL)
(CPUSH (COND (TEM) (#(NUMVALAC))))
(SETQ Y #(ILOCREG Z Y))
(COND (TEM (CPUSH TEM)
(REMOVEB Z)
(CCSWITCH TEM Y)
(SETMODE TEM 'FIXNUM)
(SETQ VALAC TEM))
(T (CCSWITCH #(NUMVALAC) Y)
(SETMODE #(NUMVALAC) 'FIXNUM)
(REMOVEB Z)
(CPUSH 1)
(COND (PNOB (SETQ VALAC #(NUMVALAC)))
(T (OUTPUT '(JSP T FXCONS))
(RPLACA NUMACS NIL))))) ;(CONT #(NUMVALAC) NIL)
(GO RETV))
((EQ (CAR X) COMP)
(AND (ATOM (CDDR X))
#(SPECIALP (CDDR X))
(CSLD (SETQ CCSLD T) T NIL))
(SETQ FNARGS (COMP1 (CDDR X)))
(COND (CCSLD)
((AND (NULL Y)
(OR (NULL SPLDLST)
(PROG2 (CLEANUPSPL T)
(OR (NULL SPLDLST)
(AND (NULL (CDR SPLDLST))
(EQ FNARGS (CAAR SPLDLST))))))))
(T (CSLD (SETQ CCSLD T) T NIL)))
(SETQ ARRAYP T T1 NIL) ;TIPS OFF LDAC BELOW THAT CCSLD HAS BEEN DONE
(SETQ X (COND ((EQ (CADR X) 'FUNCALL)
(COND ((> (LENGTH Y) #(NACS))
(SETQ VALAC (COMLC (LIST COMP 'FUNCALL FNARGS) Y NIL))
(GO CALLX)))
NIL)
((CDR X))))
(GO LDAC))
(T (BARF X |LOST COMPUTED FUNCTION| 3 5))))
(AND (EQ X PROGN) (PROG2 (REMOVE (SETQ Z (COMPROGN Y EFFS))) (RETURN Z)))
(AND (SETQ TEM (GETL X '(ARITHP NUMBERP NOTNUMP)))
EFFS
(OR (NOT (EQ (CAR TEM) 'NOTNUMP)) (EQ (CADR TEM) 'NOTNUMP))
(WARN F |YOU'RE LOSING SOME VALUE HERE| 3 5))
(COND ((AND (EQ (CAR TEM) 'NUMBERP)
(COND ((EQ (SETQ TEM (CADR TEM)) 'NOTYPE)
(SETQ Z NIL)
(COND ((COND ((MEMQ X '(EQ EQUAL))
(COND ((OR (EQ X 'EQ)
(MEMQ (CAR Y) '(FIXNUM FLONUM)))
(COMEQ Y NIL T)
T)))
((MEMQ X '(GREATERP LESSP *GREAT *LESS))
(COND (#(KNOW-ALL-TYPES (CAR Y))
(COMGRTLSP F NIL T)
T)))
((EQ X 'ODDP)
(COND ((AND (NOT CLOSED)
(MEMQ (CAR Y) '(FIXNUM FLONUM)))
(COMOP (CADR Y) NIL T)
T)))
((BARF F |LOST NOTYPE NUMBERP|)))
(BOOLOUT NIL NIL)
(GO RET-NO))
(T (SETQ F (CONS X (SETQ Y (CDR Y))))))
NIL)
((OR (EQ X 'FIX)
(NULL (CAR Y))
(AND CLOSED (NOT (ATOM (CAR Y))))) ;FOR CLOSED CHOMILIZATION
(SETQ F (CONS X (SETQ Y (CDR Y))))
NIL)
((MEMQ X '(ADD1 SUB1)) (RETURN (COMAD1SB1 X Y)))
((MEMQ X '(PLUS DIFFERENCE TIMES QUOTIENT)) (RETURN (COMARITH X Y)))
((MEMQ X '(*DIF *PLUS *TIMES *QUO HAULONG))
(AND #(KNOW-ALL-TYPES (CAR Y))
(RETURN (COND ((EQ X 'HAULONG) (COMHAULONG Y))
(T (COMARITH X Y)))))
(SETQ F (CONS X (SETQ Y (CDR Y))))
NIL)
((MEMQ X '(FIX FLOAT IFIX))
(RETURN (COMFIXFLT (COMPW (CADR Y) NIL #(NUMVALAC))
(COND ((EQ X 'FLOAT) 'FLONUM) ('FIXNUM)))))
((EQ X 'REMAINDER) (RETURN (COMREMAINDER (CDR Y))))
((MEMQ X '(ABS MINUS)) (RETURN (COMABSMINUS X Y))))))
((AND (SETQ T1 (GETL X '(EXPR FEXPR SUBR FSUBR LSUBR *EXPR *FEXPR *LEXPR)))
(OR (NOT (MEMQ (CAR T1) '(SUBR FSUBR LSUBR)))
(SYSP (CADR T1))))
; COMPILE FOR F-TYPE FUNCTION
(COND ((EQ (CAR T1) 'FSUBR)
(COND ((EQ X 'COND)
(COMCOND Y NIL NIL NIL)
(AND (NOT EFFS)
#(NUMACP ARGNO)
(NULL (CAR (SETQ TEM #(ACSMODESLOT ARGNO))))
(RPLACA TEM (COND ((NULL (SETQ Z (CADDDR Y)))
(BARF NIL |NO TYPE FOR COMCOND|))
((ATOM Z) Z)
((CADR Z)))))
(GO RET-NO))
((EQ X 'PROG)
(SETQ TEM (COMPROG Y))
(AND #(NUMACP ARGNO) (SETMODE ARGNO (COND (TEM) ('FIXNUM))))
(GO RET-NO))
((EQ X 'SETQ) (RETURN (COMSETQ Y)))
((EQ X 'GO) (COMGO Y) (RETURN ''NIL))
((AND (EQ X 'ERR) (NULL (CDR Y)))
(LOADAC (COMP1 (CAR Y)) 1 T)
(OUTPUT '(JRST 0 ERUNDO))
(GO RET))
((OR (EQ X 'COMMENT) (EQ X 'DECLARE))
(OUTPUT (CONS 'COMMENT Y))
(RETURN '(QUOTE COMMENT)))
((OR (SETQ TEM (EQ X 'AND)) (EQ X 'OR))
(COND ((NOT EFFS) (BARF F |AND OR LOSS| 3 6)))
(CLEAR (CADR Y) T)
(SETQ Y (L2F Y))
(SETQ T1 NIL)
(COND ((AND (EQ (CAAR Y) 'GO)
(NULL (CDDDDR (CDDR Y)))
(ATOM (CADAR Y))
(EASYGO))
(BOOL1 (CADDDR (CDDR Y)) (ADR (CADAR Y)) TEM))
((AND (EQ (CAAR Y) 'RETURN)
(NULL (CDDDDR (CDDR Y)))
(QNILP (CADAR Y))
(EASYGO))
(BOOL1 (CADDDR (CDDR Y)) (GENTAG EXITN 'EXITN) TEM))
(T (BOOL2 (CDR Y) (SETQ T1 (LEVELTAG)) NIL TEM)
(COMPE (CAR Y))))
(SETQ CNT (PLUS 2 CNT))
(OUTTAG T1)
(DIDUP (CADDR Y))
(GO RET))
((EQ X 'SIGNP) (COMSIGNP Y NIL NIL) (GO RETV))
((EQ X 'ERRSET) (RETURN (COMERSET T Y)))
((EQ X 'CATCH) (COMERSET NIL Y) (GO RETV))
((EQ X 'THROW)
(LOADAC (COMP1 (CAR Y)) 1 T)
#(OUTFS 'MOVEI 2 (CADR Y))
(CLEARACS0 T)
(OUTPUT '(JRST 0 (ERUNDO -1)))
(GO RET))
((EQ X 'STORE)
(COND ((AND ARRAYOPEN
(ATOM (CAAR Y))
(COND ((AND (SETQ ARRAYP (GET (CAAR Y) '*ARRAY))
(NOT (EQ ARRAYP T)))
(SETQ X (CAAR Y) Z (CDAR Y))
(AND (SETQ T1 (GET X 'NUMFUN)) (SETQ T1 (CADR T1)))
(SETQ TEM (COMPR (CADR Y) T1 NIL NIL))
T)
((EQ (CAAR Y) 'ARRAYCALL)
(SETQ T1 (CADAR Y)
TEM (COMPR (CADR Y) T1 NIL NIL)
X (COMP1 (CADDAR Y))
Z (CDDDAR Y)
ARRAYP NIL)
T)))
(SETQ Z (NREVERSE (ITEML Z '(FIXNUM FIXNUM FIXNUM
FIXNUM FIXNUM FIXNUM FIXNUM))))
(SETQ VALAC (ARRAYACCESS X Z TEM T1 ARRAYP)))
(((LAMBDA (V LOC TAKENAC1)
(CONT TAKENAC1 NIL)
(REMOVE LOC)
(LOADAC V 1 T)
(CLEARNUMACS)
(OUTPUT '(JSP T *STORE)))
(COMP1 (CADR Y))
(COMPW (CAR Y) T 1)
(+ #(NUMVALAC) 2))))
(GO RETV))
((EQ X 'ARRAYCALL)
(SETQ VALAC (COMARRAY (COMP1 (CADR Y)) (CDDR Y) NIL (CAR Y)))
(GO RETV))
((EQ X 'LSUBRCALL)
(SETQ VALAC (COMLC (LIST COMP (CAR Y) (COMP1 (CADR Y))) (CDDR Y) NIL))
(GO RETV))
((EQ X 'IOC) (SETQ Y (CAR Y)) (GO COMFXPR))
((EQ X 'IOG)
(CLEARNUMACS)
(OUTPUT '(PUSHJ P IOGBND))
(SETQ Z ((LAMBDA (GOBRKL)
(COND ((CAR Y) (COMPE (LIST 'IOC (CAR Y)))))
(COMPROGN (CDR Y) EFFS))
(CONS '(UNBIND . NIL) GOBRKL)))
(AND (NOT EFFS) (LOADAC Z 1 T))
(OUTPUT '(PUSHJ P UNBIND))
(GO RETV))
((EQ X 'PROGV)
(SETQ TEM (COMPW (CAR Y) NIL 5) T1 (COMP1 (CADR Y)))
(AND (NULL (ILOCMODE TEM 5 NIL)) (DBARF F |BAD VARIABLES LIST|))
(LOADAC TEM 5 NIL)
(LOADAC T1 1 NIL)
(CLEARACS0 T)
(OUTPUT '(JSP T VBIND))
((LAMBDA (GOBRKL)
(SETQ TEM (COMPROGN (CDDR Y) EFFS))
(COND ((AND (NULL EFFS) (CDR TEM) #(SPECIALP (CAR TEM)))
(LOADAC TEM ARGNO NIL)
(SETQ TEM NIL))
(T (AND (NULL EFFS) #(ILOCN TEM))
(REMOVEB TEM))))
(CONS '(UNBIND . NIL) GOBRKL))
(OUTPUT '(PUSHJ P UNBIND))
(COND (TEM (RETURN TEM)) ((GO RETV))))
(T (GO FX0))))
((EQ (CAR T1) 'SUBR)
; COMPILE SUBR TYPE
(COND ((EQ X 'NULL) (COMNULL (CAR Y)) (GO RET-NO))
((EQ X 'RETURN) (COMRETURN Y) (CONT PVR NIL) (RETURN ''NIL))
((MEMQ X '(RPLACA RPLACD SETPLIST)) (RETURN (COMRPLAC X Y NIL)))
((AND (MEMQ X '(PRINC *PRINC))
(EQ (CAAR Y) 'QUOTE)) ;### REMEMBER: P1 AND P1BASICBOOL1ABLE
#(OUTFS 'STRT 0 (LIST '% 'SIXBIT (6BSTR (CADAR Y))))
(RETURN '(QUOTE T)))
((AND (SETQ TEM (GET X 'P1BOOL1ABLE))
(NOT (ATOM TEM)))
(COMTP F TEM NIL T T)
(GO RET-NO))
((AND (EQ TEM T) (MEMQ X '(ZEROP PLUSP MINSUP)))
(COMZP F NIL T)
(BOOLOUT NIL NIL)
(GO RET-NO))
((EQ X 'SET)
((LAMBDA (NAME V ARGNO EFFS)
(CSLD T NIL NIL)
(SETQ NAME (COMP0 (CAR Y)))
(SETQ V (COMP0 (CADR Y)))
(LOADAC NAME 4 NIL)
(AND (SETQ NAME (GETMODE0 4 T NIL))
(PDERR F |SET APPLIED TO NUMERIC DATUM|))
(LOADAC V 1 T)
(OUTPUT '(JSP T *SET)))
NIL NIL 1 NIL)
(GO RET))
((MEMQ X '(ROT LSH FSC)) (RETURN (COMSHIFTS X Y)))
((MEMQ X '(EXAMINE DEPOSIT))
(SETQ VALAC (COND (#(NUMACP ARGNO) ARGNO)
(T (FREENUMAC))))
(SETQ T1 (COMPW (CAR Y) NIL VALAC) TEM NIL)
(AND (EQ X 'DEPOSIT) (SETQ Y (COMPW (CADR Y) NIL #(NUMVALAC))))
(SETQ T1 (COND ((AND (NOT (EQ (CAR T1) 'QUOTE))
(SETQ Z (ILOCMODE T1 NIL 'FIXNUM))
(COND (#(ACLOCP Z) (SETQ TEM (REGADP Z)) T)
((NOT (REGADP Z)))))
(REMOVE T1)
Z)
((LOCINNUMAC T1 VALAC))))
(COND ((EQ X 'EXAMINE)
(CPUSH VALAC)
(COND (TEM #(OUTFS 'MOVE VALAC '@ 0 T1))
(T (OUT1 '(MOVE) VALAC T1)))
(SETMODE VALAC 'FIXNUM)
(GO RETV))
(T ((LAMBDA (TAKENAC1) (SETQ Y (LOCINNUMAC Y 0))) T1)
(COND (TEM #(OUTFS 'MOVEM Y '@ 0 T1))
(T (OUT1 '(MOVEM) Y T1)))
(RETURN '(QUOTE T)))))
((EQ X 'ARG)
(COND ((NOT (EQ (CAAR Y) 'QUOTE))
(SETQ Z (COND (#(NUMACP ARGNO) (COMP1 (CAR Y))) ((COMP0 (CAR Y)))))
(AND EFFS (PROG2 (REMOVE Z) (GO RETV)))
(SETQ Z (LOCINNUMAC Z 0))
#(OUTFS 'ADD Z 'ARGLOC)
(SETQ Y '((QUOTE 0)))
((LAMBDA (TAKENAC1) (CPUSH ARGNO)) Z)
(CONT Z NIL))
((PROG2 (CPUSH ARGNO) (NULL (CADAR Y)))
(OUTPUT (CONS 'MOVE
(CONS ARGNO
(COND (#(NUMACP ARGNO) '(@ (ARGLOC 1)))
('((ARGLOC 1)))))))
(GO RET-ARG))
(T (COND ((SETQ Z (MEMQ ARGLOC REGACS))
(SETQ Z (- (+ 1 #(NACS)) (LENGTH Z))))
((SETQ Z (MEMQ ARGLOC NUMACS))
(SETQ Z (- (+ #(NUMVALAC) #(NUMNACS)) (LENGTH Z))))
(T (CONT (SETQ Z #(FREACB)) ARGLOC)
#(OUTFS 'MOVE Z 'ARGLOC)))))
(SETQ Z (LIST (CADAR Y) Z))
(OUTPUT (COND ((NOT #(NUMACP ARGNO)) (CONS 'HRRZ (CONS ARGNO Z)))
(T (CONS 'MOVE (CONS ARGNO (CONS '@ Z))))))
(GO RET-ARG))
((EQ X 'TYPEP)
(COND (EFFS (SETQ F (CADR F) X (CAR F) Y (CDR F)) (GO A)))
(COMTP F NIL NIL T T)
(GO RET-NO))
((EQ X 'PLIST)
(SETQ T1 #(ILOCN (SETQ Z (COMP0 (CAR Y))))
TEM (COND ((NOT (NUMBERP T1)) NIL)
((> T1 0) 'PLUSP)
(T)))
(REMOVEB Z)
(SETQ VALAC (COND ((EQ TEM 'PLUSP) (CPUSH T1) T1)
((NOT (DVP ARGNO)) ARGNO)
(#(FREAC))))
(COND ((AND (NULL TEM)
(NULL (CDR T1))
(EQ (CAAR T1) 'QUOTE))
#(OUTFS 'HRRZ
VALAC
(COND ((CADAR T1) (CAR T1))
(T 'NILPROPS))))
(T (COND ((EQ TEM 'PLUSP)
#(OUTFS 'SKIPN (COND ((= T1 VALAC) 0) (T1)) T1))
((OUT1 'SKIPN VALAC T1)))
#(OUTFS 'SKIPA VALAC 'NILPROPS)
#(OUTFS 'HRRZ VALAC 0 VALAC)
(OUTPUT 'FOO)))
(GO RETV))
((EQ X 'CXR)
(SETQ X (COMP1 (CAR Y)) Y (COMP1 (CADR Y)))
(SETQ Z (ILOCMODE Y
(COND ((EQ (CAR X) 'QUOTE) 'ARGNO) ('1))
'(NIL FIXNUM FLONUM)))
(COND ((AND (AND (NUMBERP Z) #(REGACP Z))
(OR (= Z 1) (EQ (CAR X) 'QUOTE)))
(REMOVEB Y)
(CPUSH Z))
(T (SETQ Z (COND ((NOT (EQ (CAR X) 'QUOTE)) 1)
((AND (AND (NOT EFFS) (NOT #(NUMACP ARGNO)))
(COND ((NOT (DVP ARGNO)))
(T (CPUSH1 ARGNO 'CLEARVARS NIL)
(NOT (DVP1 SLOTX ARGNO)))))
ARGNO)
((FREEREGAC 'FRACB))))
(LOADAC Y Z NIL)))
(SETQ VALAC Z)
(COND ((EQ (CAR X) 'QUOTE)
(SETQ NARGS (CADR X))
(AND (OR (NOT (FIXP (CADR X)))
(< NARGS 0)
(> NARGS 77))
(DBARF F |ILGL ARG - CXR|))
(REMOVE X)
#(OUTFS (COND ((ODDP NARGS) 'HLRZ) ('HRRZ))
Z
(LSH NARGS -1)
Z))
(T (LOADAC X #(NUMVALAC) NIL)
(OUTPUT '(JSP T %CXR))))
(GO RETV))
((EQ X 'MUNKAM)
(SETQ Z (COMP0 (CAR Y)))
(SETQ VALAC (COND ((AND #(ACLOCP (SETQ TEM #(ILOCN Z)))
(NOT #(NUMACP TEM)))
TEM)
(#(NOT (NUMACP ARGNO))
ARGNO)
((FRAC5))))
(REMOVEB Z)
(COND ((AND (NUMBERP TEM) #(NUMACP TEM))
((LAMBDA (TAKENAC1) (CPUSH VALAC)) TEM))
((CPUSH VALAC)))
(OUT1 (COND ((REGADP TEM) '(HRRZ)) ('HRRZ)) VALAC TEM)
(GO RETV))))
((MEMQ (CAR T1) '(EXPR *EXPR)))
((MEMQ (CAR T1) '(*LEXPR LSUBR))
; COMPILE L TYPE
(COND ((EQ X 'PROG2)
(COMPE (CAR Y))
(SETQ T1 (COMP0 (CADR Y)))
(MAPC 'COMPE (CDDR Y))
(REMOVE T1)
(RETURN T1))
((AND (EQ X 'BOOLE) (EQ (CAAR Y) 'QUOTE)) (RETURN (COMBOOLE Y)))
((AND (EQ X 'PRINC) (EQ (CAAR Y) 'QUOTE))
(SETQ T1 (COND ((NULL (CDR Y)) 0)
((EQ (CAR (SETQ T1 (COMP (CADR Y)))) 'MSGFILES) 17)
((LOCINAC T1 'FRACB NIL NIL))))
#(OUTFS 'STRT T1 (LIST '% 'SIXBIT (6BSTR (CADAR Y))))
(RETURN '(QUOTE T))))
(SETQ VALAC (COMLC X Y NIL))
(GO RETV))
(T (GO COMFXPR))))
((SETQ ARRAYP (GET X '*ARRAY))
(COND ((AND ARRAYOPEN (NOT (EQ ARRAYP T)))
(SETQ VALAC (COMARRAY X Y ARRAYP NIL)) (GO RET))))
((OR (SETQ TEM #(SPECIALP X)) (MEMQ X BVARS))
(AND TEM (CSLD (SETQ CCSLD T) T NIL))
(SETQ FNARGS (COMP1 X))
(SETQ X (AND TEM NULFU)))
((EQ X GOFOO)
((LAMBDA (AC)
(OUTPUT '(PUSH P (% 0 0 'NIL)))
#(PUSH (LIST (CAR Y)) REGPDL)
(OUTPUT (CONS 'MOVEI (CONS AC '(0 P))))
(CONT AC (LIST (CADR Y))))
(FRAC1))
(SETQ OLVRL (DELQ (CAR Y) (DELQ (CADR Y) OLVRL)))
(GO RET))
(T (BARF X |LOST FUNCTION|)))
; SO COMPILE FOR NORMAL EXPR TYPE
(COND ((AND (EQ X 'CONS) (EQUAL (CADR Y) ''NIL))
(SETQ Y (LIST (CAR Y)))
(SETQ X 'NCONS)))
(SETQ T1 (COND ((GET X 'NUMFUN))
((MEMQ X '(CONS XCONS NCONS)) '((T T) NIL T T))
((OR (MEMQ X '(NORET *NOPOINT *RSET NOUUO HUNK))
(AND (EQ X 'GCTWA) Y (NULL (CDR Y))))
'((T) NIL T))
((EQ X 'RPLACX) '((T NIL NIL) NIL NIL NIL T))
((MEMQ X '(SUBST PUTPROP)) '((T T T) NIL T T T))
((FUNMODE X))))
LDAC (COND ((OR ARRAYP
(GET X 'ACS)
(NULL SPLDLST)
(NULL LDLST)
(NULL (FLUSH-SPL-NILS)))
(SETQ Z (ITEML Y T1))
(SETQ TEM NIL)
(COND ((AND (CDR Y) ;COMMUTATIVE 2-ARG FUNCTION
(NULL (CDDR Y)) ;2ND ARG IN AC 1, 1ST ARG
(NULL ARRAYP)
(SETQ TEM (GET X 'COMMU)) ;NOT IN AC 1
(OR (EQUAL (ILOC0 (CAR Z) NIL) 1)
;;;2ND ARG IS EITHER ALREADY IN AC 1, OR MUST BE BROUGHT IN THERE DUE TO P2NUMCONSING
(AND T1 (EQ (CADDDR T1) T)
(P2CONSABLE (CAR Z))))
(NOT (EQUAL (ILOC0 (CADR Z) NIL) 1))
;;;1ST ARG IS NOT IN AC 1, AND WONT HAVE TO BE BROUGHT IN FOR P2NUMCONSING
(NOT (AND T1 (EQ (CADDR T1) T)
(P2CONSABLE (CADR Z)))))
(SETQ Z (REVERSE Z))
(SETQ X TEM)))
(LOADACS Z (SETQ NARGS (LENGTH Z)) T1))
(T (CSLD (SETQ CCSLD T) T NIL)
; DOES SPECIAL VAR S AND ALL CARCDR LOAD S
(SETQ NARGS (LENGTH (SETQ Z (ITEML Y T1))))
(LOADACS Z NARGS T1)))
; OUTPUT A "CALL" TO THE FUNCTION
CALL (COND (FNARGS
(SETQ TEM #(PDLLOCP (SETQ T1 (ILOCMODE FNARGS 'FRACF NIL))))
(REMOVEB FNARGS)
(AND (CLEARACS0 T) TEM (SETQ T1 (ILOC0 FNARGS NIL)))
(COND ((NULL X)
(OUT1 (COND ((AND (OR #(NUMACP ARGNO) PNOB)
(VARBP (CAR FNARGS))
(SETQ F (OR (FUNMODE (CAR FNARGS))
(GET 'FNARGS 'NUMFUN)))
(SETQ F (CADR F)))
(RPLACA ACSMODE F) ;(SETMODE #(NUMVALAC) FOO)
(SETQ VALAC #(NUMVALAC))
'(NCALLF . NCALLF))
('(CALLF . CALLF)))
NARGS
T1))
(T (COND ((MEMQ (CAR X) '(FIXNUM FLONUM))
(OUT1 'MOVE #(NUMVALAC) T1)
(OUTPUT ##(SUBST (NUMVALAC) 'AC ''(PUSHJ P 1 AC)))
(RPLACA ACSMODE (CAR X))
(SETQ VALAC #(NUMVALAC)))
((OUT1 '(PUSHJ) 'P T1)))))
(AND TEM (OUTPUT 'FOO)))
(T (CLEARACS1 X NIL)
(SETQ VALAC (OUTFUNCALL 'CALL NARGS X))))
CALLX (COND (CCSLD (DIDUP CLPROGN))) ; DELETES IDUPS IF CSLD WAS CALLED
RETV (AND EFFS (CONT VALAC NIL))
RET (RETURN (AND (NULL EFFS) (CAR (CONT VALAC (LIST (GENSYM))))))
RET-NO (SETQ VALAC ARGNO)
(GO RETV)
RET-ARG (RETURN (CAR (CONT ARGNO (COND (EFFS NIL)
(T #(PUSH (SETQ Z (GENSYM)) UNSFLST)
(LIST Z))))))
COMFXPR (CSLD (SETQ CCSLD T) T NIL)
FX0 (CPUSH 1)
(OUT1 'MOVEI 1 (LIST 'QUOTE Y))
(CONT 1 NIL)
FX1 (SETQ NARGS 17)
; 17 TO INDICATE F TYPE CALL, NOTICE THAT FNARGS = NIL
(GO CALL)))
(DEFUN COMABSMINUS (FUN ARG)
((LAMBDA (OP ARG AC TYPE LARG)
(SETQ LARG (ILOCMODE ARG 'FREENUMAC TYPE))
(REMOVE ARG)
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'MOVE)
(NUMBERP LARG)
#(NUMACP LARG)
(NOT (DVP LARG))
(NUMBERP (CADR LOUT))
(= (CADR LOUT) LARG))
(RPLACA LOUT (CAR OP))
(SETQ AC LARG))
(T (COND ((AND (NUMBERP LARG) #(NUMACP LARG))
(SETQ AC LARG)
(CPUSH LARG)
#(OUTFS (COND ((EQ (CAR OP) 'MOVN) 'MOVNS) ('MOVMS))
0
LARG))
(T (OUT3 OP (SETQ AC (FREENUMAC)) LARG)))))
(SETMODE AC TYPE)
(CAR (CONT AC (LIST (GENSYM)))))
(COND ((EQ FUN 'MINUS) '(MOVN)) ((EQ FUN 'ABS) '(MOVM)))
(COMPW (CADR ARG) NIL #(NUMVALAC))
0
(CAR ARG)
NIL))
(DEFUN COMAD1SB1 (FUN ARG)
((LAMBDA (AC N)
(AND (EQ (CAR ARG) 'FLONUM) (SETQ N (+ N 2)))
(AND (EQ FUN 'SUB1) (SETQ N (1+ N)))
(OUTPUT (A1S1A (- AC #(NUMVALAC)) N))
(SETMODE AC (CAR ARG))
(CAR (CONT AC (LIST (GENSYM)))))
(LOCINNUMAC (COMPW (CADR ARG) NIL #(NUMVALAC)) 0)
0))
(DEFUN COMARITH (FUN LL)
((LAMBDA (MIXP TYPEL ARGL)
(SETQ TYPEL (COND ((NULL (CAR LL)) (CAR COMAL))
((EQ (CAR LL) 'FIXNUM) (CADR COMAL))
((EQ (CAR LL) 'FLONUM) (CADDR COMAL))
(T (SETQ MIXP (MEMQ 'NIL (CAR LL))) (CAR LL))))
(SETQ ARGL ((LAMBDA (ARGNO EFFS PNOB TEM)
(MAPCAR '(LAMBDA (ARG TYPE)
(COND (TYPE
(FREEIFYNUMAC)
(SETQ ARGNO #(NUMVALAC))
(SETQ ARG (COMP0 ARG))
(AND (NOT (EQ (CAR ARG) 'QUOTE))
(SETQ TEM (ASSQ (CAR ARG) NUMACS))
(NULL (GETMODE0
(- ##(+ #(NUMVALAC) #(NUMNACS))
(LENGTH (MEMQ TEM NUMACS)))
T
NIL))
(NUMODIFY ARG TYPE))
ARG)
(T (SETQ ARGNO 1)
(COMP0 ARG))))
(CDR LL)
TYPEL))
#(NUMVALAC) NIL NIL NIL))
(COND ((OR (EQ TYPEL (CAR COMAL)) MIXP)
(CAR (CONT (COMLC FUN ARGL T) (LIST (GENSYM)))))
((PROG (ARG1 ARG2 OP AC AD MODE)
(SETQ AC 0 MODE (CAR TYPEL))
(SETQ OP (CDR (ASSQ FUN (COND ((EQ MODE 'FIXNUM)
'((PLUS ADD) (DIFFERENCE SUB)
(TIMES IMUL) (QUOTIENT IDIV)))
(T '((PLUS FADR) (DIFFERENCE FSBR)
(TIMES FMPR) (QUOTIENT FDVR)))))))
(REMOVE (SETQ ARG1 (CAR ARGL)))
A (AND (NULL (SETQ ARGL (CDR ARGL))) (RETURN ARG1))
(COND ((CDR TYPEL) (SETQ TYPEL (CDR TYPEL))))
(SETQ ARG2 (CAR ARGL))
(COND ((NOT (EQ MODE (CAR TYPEL)))
(COND ((EQ MODE 'FIXNUM)
(SETQ ARG1 (COMFIXFLT ARG1 (SETQ MODE 'FLONUM)))
(SETQ OP (CDR (ASSQ (CAR OP) '((ADD FADR) (SUB FSBR)
(IMUL FMPR) (IDIV FDVR))))))
(T #(PUSH ARG1 LDLST)
#(PUSH (SETQ ARG2 (COMFIXFLT ARG2 'FLONUM)) LDLST)))))
(COND ((AND (MEMQ FUN '(PLUS TIMES))
(NOT #(ACLOCP (ILOC0 ARG1 MODE)))
#(ACLOCP (SETQ AD (ILOC0 ARG2 MODE))))
(REMOVEB ARG2)
(CPUSH (SETQ ARG2 ARG1 AC AD)))
((EQ (CAR OP) 'IDIV)
(SETQ AD ((LAMBDA (TAKENAC1) (FREENUMAC))
##(+ (NUMVALAC) (NUMNACS) -1)))
(SETQ AC (LOCINNUMAC ARG1 AD))
(COND ((= AC ##(+ (NUMVALAC) (NUMNACS) -1))
(LOADAC ARG1 AD NIL)
(CONT AC NIL)
(SETQ AC AD))))
(T (SETQ AC (LOCINNUMAC ARG1 0))))
(COND ((AND (EQ FUN 'TIMES) ;TRAP FOR MUL BY POWER OF 2
(EQ MODE 'FIXNUM)
(QNP ARG2)
#(/2↑N-P (CADR ARG2)))
(REMOVE ARG2)
(COND ((> (CADR ARG2) 1)
#(OUTFS 'ASH AC (1- (HAULONG (CADR ARG2)))))
((= (CADR ARG2) 0) #(OUTFS 'MOVEI AC 0)))
(GO B)))
(SETQ AD ((LAMBDA (TAKENAC1) #(ILOCNUM ARG2 'FREENUMAC)) AC))
(REMOVEB ARG2)
(COND ((EQ (CAR OP) 'IDIV)
((LAMBDA (II)
(AND (COMDDLPDLP II AD) ;LEAVES SLOTX SET AT II
(SETQ AD (1- AD)))
(RPLACA SLOTX NIL)
(SETMODE AC NIL))
(1+ AC)))
((AND #(ACLOCP AD) (= AD 7) (MEMQ FUN '(PLUS TIMES)))
(SETQ AD AC AC 7)))
(AND (COMDDLPDLP AC AD) (SETQ AD (1- AD)))
(OUT3 OP AC AD)
B (SETMODE AC MODE)
(SETQ ARG1 (CAR (CONT AC (LIST (GENSYM)))))
(GO A)))))
NIL NIL NIL))
(DEFUN COMDDLPDLP (ACX AD)
(FIND ACX)
(AND (DVP1 SLOTX ACX) ;HAVE I DIDDLED WITH THE PDL FOR WHICH
(EQ (CPUSH1 ACX NIL AD) 'PUSH) ;THE ADDRESS AD IS A OFFSET THEREOF?
#(PDLLOCP AD)
(EQ (GETMODE ACX) (GETMODE AD))))
(DEFUN COMARRAY (X Y FORM MODE)
(SETQ Y (NREVERSE
(ITEML Y (COND ((AND FORM (SETQ Y (GET X 'NUMFUN))) (SETQ MODE (CADR Y)) Y)
((NCDR '(FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM)
(- 5 (LENGTH Y))))))))
(ARRAYACCESS X Y NIL MODE FORM))
(DEFUN COMBOOLE (ARGL)
((LAMBDA (N ARGNO EFFS Y)
(SETQ Y (CAR ARGL))
(AND (OR (NOT (FIXP (CADR Y))) (< (SETQ N (CADR Y)) 0) (> N 17))
(BARF ARGL |INCONSTANT TYPE - COMBOOLE|))
(SETQ ARGL (MAPCAR 'COMP0 (CDR ARGL)))
((LAMBDA (AC ARG1 AD)
(COND ((NOT (OR (= N 3) (= N 5) (= N 12) (= N 14) (= N 0) (= N 17)))
(DO ((ARGL (CDR ARGL) (CDR ARGL))) ((NULL ARGL) ARG1)
(COND ((AND (NOT #(ACLOCP (ILOC0 ARG1 'FIXNUM)))
#(ACLOCP (SETQ AD (ILOC0 (CAR ARGL) 'FIXNUM))))
(REMOVEB (CAR ARGL))
(CPUSH AD)
(SETQ AC AD
AD ((LAMBDA (TAKENAC1) #(ILOCNUM ARG1 'FREENUMAC)) AC))
(COND ((OR (= N 2) (= N 13)) (SETQ N (+ N 2)))
((OR (= N 4) (= N 15)) (SETQ N (- N 2))))
(REMOVEB ARG1))
(T (SETQ AC (LOCINNUMAC ARG1 0))
((LAMBDA (TAKENAC1) (SETQ AD #(ILOCNUM (CAR ARGL) 'FREENUMAC))) AC)
(REMOVEB (CAR ARGL))))
(COND ((AND (NOT ATPL) (EQ (CAR LOUT) 'MOVE) (EQUAL (CADR LOUT) AD))
(CONT AD NIL)
(SETQ LOUT (CONS (CAR (CBA N)) (CONS AC (CDDR LOUT)))))
(T (OUT3 (CBA N) AC AD)))
(AND (CDR ARGL) (CONT AC (CAR #(PUSH (SETQ ARG1 (LIST (GENSYM))) LDLST))))
(SETMODE AC 'FIXNUM)))
(T (COND ((OR (= N 0) (= N 17))
#(OUTFS (CBA N) (SETQ AC (FREENUMAC)) AC))
(T (COND ((OR (= N 3) (= N 14))
(SETQ ARG1 (CAR (LAST ARGL)))))
(SETQ AC (LOCINNUMAC ARG1 0))
(COND ((OR (= N 12) (= N 14))
(COND ((AND (NOT ATPL) (NOT (EQ (CAR LOUT) 'MOVE)))
(RPLACA LOUT (CBA 12)))
(T (OUTPUT (LIST (CBA 14) AC))))))))
(MAPC 'REMOVEB ARGL)
(SETMODE AC 'FIXNUM)))
(CAR (CONT AC (LIST (GENSYM)))))
0 (CAR ARGL) NIL))
0 #(NUMVALAC) NIL NIL))
(DEFUN COMCOND (Y BTEST F C@LCP)
; TYPICAL Y = (COMPLEXITY SETQLIST CONDUNSF MODE CLAUSE 1 - - CLAUSE N)
(AND C@LCP (NOT (GET C@LCP 'LEVEL)) (CPVRL))
(CLEAR (CADR Y) T)
((LAMBDA (CEXIT EXLDL CLZTAG SVSPLDLST TEM ACX LASTCLZP JSP SNILP PNOB CONDPNOB)
(COND ((AND (NOT EFFS) ;A COND FOR VALUE WHICH IS
(NOT BTEST) ;COMPLEX ENOUGH TO WARRANT
(NOT (= ARGNO 1)) ;SWITCHING THE VALAC TO 1
(> (CAR Y) 1)
(NOT #(NUMACP ARGNO)))
(SETQ ARGNO 1)))
(DO EXP (CDDDDR Y) (CDR EXP) (NULL EXP)
(SETQ SNILP T)
(SETQ LASTCLZP (NULL (CDR EXP)))
(COND ((OR (NULL (CDAR EXP)) (EQ (CADAR EXP) NULFU))
; COND PAIR WITH ONLY ONE PART
; OR LIKE ((NULL EXP) NIL) FOR VALUE
; EXPRESSED AS (EXP NULFU)
(COND (BTEST
(COND ((OR F LASTCLZP (CDAR EXP))
(BOOL1LCK (CAAR EXP) BTEST F))
(T (BOOL1LCK (CAAR EXP) CEXIT T)))
(CLEARVARS))
(EFFS (COND (LASTCLZP (COMPE (CAAR EXP)))
((BOOL1LCK (CAAR EXP) CEXIT T)))
(CLEARVARS))
((AND (NOT LASTCLZP) (NULL (CDAR EXP))
#(NUMACP ARGNO))
(SETQ CLZTAG (LEVELTAG))
(SETQ TEM (COMPR (CAAR EXP) NIL T T))
(BOOL3 TEM NIL CLZTAG NIL)
(LOCINNUMAC TEM 0)
(CLEARVARS)
(OJRST CEXIT NIL)
(OUTTAG0 CLZTAG)
(SLOTLISTSET (GET CLZTAG 'LEVEL)))
(T ((LAMBDA (PNOB) (LOADAC (COMP (CAAR EXP))
ARGNO
(NOT CONDPNOB)))
CONDPNOB)
(CLEARVARS)
(AND (NOT LASTCLZP)
(COND ((OR #(NUMACP ARGNO)
(AND (NOT ATPL)
(EQ (CAR LOUT) 'JSP)
(MEMQ (CADDR LOUT) '(FXCONS FLCONS))))
(OJRST CEXIT NIL))
(T
(COND ((SETQ TEM (BADTAGP CEXIT))
(OUTJ (COND ((CDAR EXP) 'JUMPN)
('JUMPE))
ARGNO
TEM)
(OJRST CEXIT NIL)
(SLOTLISTSET (GET TEM 'LEVEL))
(OUTTAG0 TEM))
((OUTJ (COND ((CDAR EXP) 'JUMPE)
('JUMPN))
ARGNO
CEXIT)))))))))
((AND (SETQ TEM (NULL (CDDAR EXP)))
(EQ (CAADAR EXP) 'GO)
(ATOM (CADADR (CAR EXP)))
(EASYGO))
; LIKE "(EXP (GO FOO))"
(SETQ SNILP (BOOL1 (CAAR EXP) (ADR (CADADR (CAR EXP))) T)))
((AND TEM
(EQ (CAADAR EXP) 'RETURN)
(QNILP (CADR (CADAR EXP)))
(EASYGO))
; LIKE "(EXP (RETURN NIL))"
(SETQ SNILP (BOOL1 (CAAR EXP) (GENTAG EXITN 'EXITN) T)))
((AND (NOT EFFS) ;(COND . . .
(NOT BTEST) ; ((FOO BAR) . . . X)
(COND ((NULL (CDR EXP)) ; (T Y))
(SETQ TEM ''NIL) ;OR LATTER CLAUSE MIGHT SIMPLY BE
(OR (ATOM (CAAR EXP)) ; (Y), OR BE ABSENT [EG, (T NIL)]
(P1BOOL1ABLE (CAAR EXP))))
((NULL (CDDR EXP)) ;X MUST BE VAR, OR QUOTED
(SETQ TEM ;Y MUST BE 1INSP
(COND ((NULL (CDR (SETQ TEM (CADR EXP))))
(CAR TEM))
((AND (NULL (CDDR TEM))
(EQ (CAAR TEM) 'QUOTE)
(CADR TEM))
(CADR TEM)))) ;X HELD BY JSP, Y BY TEM
(COND ((NULL TEM) NIL)
((ATOM TEM) (1INSP TEM))
((MEMQ (CAR TEM) '(QUOTE FUNCTION)))
(#(NUMACP ARGNO) NIL)
((AND (NOT (ATOM (CAR TEM)))
(EQ (CAAR TEM) CARCDR)
(NULL (CDDAR TEM))
(ATOM (CADR TEM)))))))
(PROG2 (SETQ SVSPLDLST (CDDAR EXP) ACX NIL) T)
(COND ((ATOM (SETQ JSP (CAR (LAST (CAR EXP)))))
(COND ((NULL (SETQ ACX (1INSP JSP))) NIL)
((NOT (EQ ACX CLPROGN))
(SETQ ACX NIL)
T)
(T (SETQ ACX T)
(AND (NULL SVSPLDLST)
(COND ((ATOM TEM) (NOT (VARMODE TEM)))
((QNILP TEM)))))))
((EQ (CAR JSP) 'QUOTE)
(AND (NULL SVSPLDLST)
(COND (#(SYMBOLP TEM)
(OR #(NUMACP ARGNO)
(NOT (VARMODE TEM))))
((QNILP TEM)))
(SETQ ACX T))
T)))
(AND ACX (SETQ ACX TEM TEM JSP JSP ACX ACX T)) ;ACX=T => INVERTED TEST
(SETQ CLZTAG NIL)
(CPUSH ARGNO)
(COND ((AND (NULL SVSPLDLST)
(COND ((ATOM (CAAR EXP))
(SETQ SVSPLDLST (CAAR EXP))
T)
((AND (EQ (CAAAR EXP) 'NULL)
(ATOM (CADAAR EXP)))
(SETQ ACX (NULL ACX) SVSPLDLST (CADAAR EXP))
T)))
(REMOVE (SETQ SVSPLDLST (COMP0 SVSPLDLST)))
(OUT1 (COND (ACX 'SKIPN) ('SKIPE))
0
#(ILOCN SVSPLDLST)))
((COND (SVSPLDLST NIL)
((CCHAK-BOOL1ABLE (CAAR EXP) ACX))
((AND (EQ (CAAAR EXP) 'NULL)
(CCHAK-BOOL1ABLE (CADAAR EXP) (NULL ACX))))))
(T (SETQ CLZTAG (LEVELTAG))
(BOOL1 (CAAR EXP) CLZTAG ACX)
(AND (CDDAR EXP)
(MAPC 'COMPE (CDR (L2F (CDAR EXP)))))
(CLEARVARS)
(RST CLZTAG)))
(REMOVE (SETQ JSP (COMP0 JSP)))
(SETQ JSP (ILOCMODE JSP
ARGNO
(COND (#(NUMACP ARGNO) '(FIXNUM FLONUM))
('(NIL FIXNUM FLONUM)))))
(COND ((OR (AND (SETQ ACX (NUMBERP JSP)) (= ARGNO JSP))
(AND (NULL ACX)
(NULL (CDR JSP))
(EQUAL (CAR JSP) (CONTENTS ARGNO))))
(COND ((AND (NOT CLZTAG)
(NOT ATPL)
(SETQ ACX (GET (CAR LOUT) 'CONV)))
(RPLACA LOUT ACX))
((OUTPUT '(SKIPA)))))
((NOT #(NUMACP ARGNO))
(COND ((AND (NOT ACX) (QNILP (CAR JSP)))
(OUTPUT (CAR (BOLA ARGNO))))
(T (OUT1 'SKIPA ARGNO JSP))))
((AND (NOT ACX) (NULL (CDR JSP)) (Q0P (CAR JSP)))
#(OUTFS 'TDZA ARGNO ARGNO))
(T (OUT3 '(SKIPA) ARGNO JSP)))
(COND (CLZTAG (OUTPUT CLZTAG)
(SETQ SVSPLDLST (LIST REGACS NUMACS ACSMODE))
(SLOTLISTSET (LEVEL CLZTAG))))
(REMOVE (SETQ TEM (COMP0 TEM)))
(COND (#(NUMACP ARGNO)
(OUT3 '(MOVE) ARGNO #(ILOCNUM TEM ARGNO)))
((PROG2 (SETQ JSP LOUT ACX #(ILOCREG TEM ARGNO))
(COND ((NOT (NUMBERP ACX)) (SETQ JSP T))
((NOT (= ACX ARGNO))
(SETQ JSP NIL)
(AND (NOT #(NUMPDLP ACX)) ;SINCE ACX IS NUMBERP, THIS IS
(NOT #(NUMACP ACX)) ;AN OPEN-CODING OF REGADP
(SETQ JSP T))
T)))
(OUT1 (COND (JSP 'MOVE)
(T (AND #(NUMACP ACX)
(OR (NOT (EQ (CDR (CONTENTS ACX)) 'DUP))
(PROG2 (CONT ACX NIL) NIL)
(NOT #(PDLLOCP (SETQ ACX #(ILOCNUM TEM NIL)))))
(BARF TEM |LOST SKIP HAC - CCMOD|))
'MOVEI))
ARGNO
ACX))
((NOT (EQ JSP LOUT)))
(T ((LAMBDA (INST)
(COND ((OR (COND (CLZTAG ATPL1) (ATPL))
(NOT (MEMQ (CAR INST) '(TDZA SKIPA))))
(BARF INST |SUSSMAN LOSES - CCMOD|))
((EQ (CAR INST) 'TDZA)
(SETQ INST (CONS 'SETZM (CONS '0 (CDDR INST)))))
(T (SETQ INST (CONS 'MOVE (CDR INST)))))
(COND (CLZTAG (SETQ LOUT1 INST))
(T (SETQ LOUT INST))))
(COND (CLZTAG LOUT1) (LOUT)))))
(OUTPUT 'FOO)
(AND CLZTAG (ACSMRGL SVSPLDLST))
(SETQ SNILP T)
(AND (CDR EXP) (SETQ EXP (CDR EXP))))
(T (SETQ CLZTAG (LEVELTAG))
(COND ((AND BTEST (NULL F) LASTCLZP)
(BOOL1LCK (CAAR EXP) BTEST NIL))
((AND EFFS LASTCLZP)
(BOOL1LCK (CAAR EXP) CEXIT NIL))
((BOOL1 (CAAR EXP) CLZTAG NIL)))
(SETQ SVSPLDLST (APPEND (FLUSH-SPL-NILS) NIL))
(SETQ ACX NIL)
(COMPROGN (CDR (SETQ TEM (L2F (CDAR EXP)))) T)
(COND ((EQ (CAAR TEM) 'COND)
(RST CEXIT)
((LAMBDA (PNOB)
(COMCOND (CDAR TEM) BTEST F CEXIT))
CONDPNOB))
(BTEST (BOOL1 (CAR TEM) BTEST F))
(EFFS (COMPE (CAR TEM)))
(T (SETQ ACX ARGNO)
(SETQ TEM ((LAMBDA (PNOB) (COMP0 (CAR TEM)))
CONDPNOB))
(COND ((OR (NOT (QNILP TEM))
(AND (NOT (QNILP (CONTENTS ACX)))
(COND ((NOT LASTCLZP))
((SETQ SNILP NIL)))))
(LOADAC TEM ACX (NOT CONDPNOB)))
((REMOVEB TEM)))))
(COND ((NOT (SETQ JSP (AND (NOT ATPL) (EQ (CAR LOUT) 'JRST))))
(CLEARVARS)
(COND ((OR (NOT LASTCLZP)
(AND SNILP
(NOT EFFS)
(NOT BTEST)
(GET CLZTAG 'USED)
(SNILPTST CLZTAG)))
(SETQ SNILP NIL)
(OJRST CEXIT ACX))
(T (RST CEXIT)))))
(OUTPUT 'FOO)
(SETQ SPLDLST SVSPLDLST)
(SETQ TEM (COND ((COND ((NOT LASTCLZP))
((GET CLZTAG 'USED)
(AND SNILP
(NOT EFFS)
(NOT BTEST)
(SNILPTST CLZTAG)
(SETQ SNILP NIL))
T))
(OUTTAG0 CLZTAG)
(LEVEL CLZTAG))
((AND (NOT C@LCP) (GET CEXIT 'USED))
(COND ((NOT (EQ (SETQ TEM (LEVEL CEXIT)) PRSSL)) TEM)
((MAPCAR '(LAMBDA (X) (APPEND X NIL)) TEM))))))
(COND ((NULL TEM))
((AND LASTCLZP (NOT JSP) (NOT C@LCP))
(ACSMRGL TEM))
(T (SLOTLISTSET TEM))))))
(COND (BTEST (COND ((AND (NOT F) (NOT SNILP)) (OJRST BTEST NIL))))
((AND (NOT EFFS) (NOT SNILP)) (OUT1 'MOVEI ARGNO '(QUOTE NIL))))
(SETQ CNT (PLUS CNT 2))
(COND (C@LCP)
((OUTTAG CEXIT))
(T (CLEARVARS) (RST CEXIT)))
(DIDUP (CADR Y)))
(COND (C@LCP) ((LEVELTAG)))
LDLST
NIL NIL NIL NIL NIL NIL NIL NIL PNOB))
(DEFUN SNILPTST (CLZTAG)
(NOT ((LAMBDA (REGACS) (QNILP (CONTENTS ARGNO))) (CAR (LEVEL CLZTAG)))))
(DEFUN CCHAK-BOOL1ABLE (EXP ACX)
(AND (P1BASICBOOL1ABLE EXP)
(NOT (MEMQ (CAR EXP) '(SIGNP NULL PROG2)))
((LAMBDA (PROP)
(COND ((OR (NOT (EQ PROP 'NUMBERP))
(OR (EQ (CAR EXP) 'ODDP) ;LIMIT GREATERP AND LESSP
(AND (CDDDR EXP) (NULL (CDDDDR EXP)))));TO TWO ARGS
(COND ((MEMQ (CAR EXP) '(EQ EQUAL))
(COMEQ (CDR EXP) NIL ACX))
((MEMQ (CAR EXP) '(GREATERP LESSP))
(COMGRTLSP EXP NIL ACX))
((EQ (CAR EXP) 'ODDP)
(COMOP (CADDR EXP) NIL ACX))
((MEMQ (CAR EXP) '(ZEROP PLUSP MINUSP))
(COMZP EXP NIL ACX))
(T (COMTP EXP PROP NIL ACX NIL)))
T)))
(GET (CAR EXP) 'P1BOOL1ABLE))))
(DEFUN COMEQ (EXP TAG F)
; COMPILE EQ. JRST TO TAG, OR SKIP ONE LOC, IF SENSE IS NORMAL [F NON-NIL]
; RETURN NON-NIL IFF JUMP TO TAG IS BEING OUTPUTTED BY COMEQ
(PROG (X Y Y/' LX LY AC TYPEL TYPX TYPY TEMP N)
(SETQ N 1)
(SETQ TYPEL (SETQ TYPY (SETQ TYPX (CAR EXP))) EXP (CDR EXP))
(COND (TYPEL
(AND (NOT (MEMQ TYPEL '(FIXNUM FLONUM)))
(SETQ TYPX (CAR TYPEL) TYPY (CADR TYPEL)))
(OR (AND (EQ TYPX 'FIXNUM)
(SETQ TEMP (COND ((Q0P (SETQ X (CAR EXP))) 0)
((Q1P X) 1))))
(AND (EQ TYPY 'FIXNUM)
(SETQ TEMP (COND ((Q0P (SETQ Y (CADR EXP))) 0)
((Q1P Y) 1)))))))
(COND ((AND TEMP TAG)
(AND (NOT Y) (SETQ X (CADR EXP)))
(SETQ AC (LOCINNUMAC (COMPW X NIL #(NUMVALAC)) 0))
(OUTJ (COND ((ZEROP TEMP)
(COND (F 'JUMPE) ('JUMPN)))
((COND (F 'SOJE) ('SOJN))))
AC
TAG)
(AND (= TEMP 1) (SETMODE AC NIL) (CONT AC NIL))
(RETURN T)))
(NUMODIFY (SETQ X (COMPW (CAR EXP) NIL (COND (TYPX #(NUMVALAC)) (1)))) TYPX )
(SETQ Y (COMPW (CADR EXP) NIL (COND (TYPY (FREENUMAC))
((AND (NULL TYPX)
(NOT EFFS)
(EQUAL 1 (ILOC0 X NIL)))
ARGNO)
(1))))
; POSSIBLY LY = 1 BUT Y = (SPECIAL FOO) OR (QUOTE FOO)
; WILL CAUSE LX TO BECOME 1
(SETQ LY (ILOCMODE Y (COND (TYPY 'FREENUMAC) ('FRACF)) TYPY))
(SETQ LX (ILOCMODE X (COND (TYPX 'FREENUMAC) ('FRACF)) TYPX))
(COND ((OR (AND TYPEL (NOT (ATOM X)) (EQ (CAR X) 'QUOTE)
(NUMBERP (CADR X)))
(AND TYPY (NOT TYPX)))
(SETQ TEMP X X Y Y TEMP)
(SETQ TEMP LX LX LY LY TEMP)
(SETQ TEMP TYPX TYPX TYPY TYPY TEMP)))
(COND ((AND #(ACLOCP LX) (NOT (AND TYPX (REGADP LX))))
(SETQ AC LX)
(AND (NUMBERP LY)
(= LY 1)
(NOT (EQUAL Y (CAR REGACS)))
(SETQ LY (ILOC0 Y NIL)))
(SETQ Y/' Y)
(REMOVE X))
((AND #(ACLOCP LY) (NOT (AND TYPY (REGADP LY))))
(SETQ AC LY LY LX Y/' X X Y TEMP TYPX TYPX TYPY TYPY TEMP)
(REMOVE X))
(T (SETQ AC (COND ((NOT TYPX)
(COND ((DVP1 REGACS 1) (LOCINAC X NIL NIL LX))
(T (LOADAC X 1 NIL) 1)))
((LOCINNUMAC X 0))))
(SETQ Y/' Y)))
; AT THIS POINT
; AC CONTAINS LOC OF ONE ARG
; X IS INTERNAL FORM OF THAT ARG
; LY HAS LOC OF OTHER
; Y/' IS INTERNAL FORM OF ARG IN LY
(COND (TAG (CLEARVARS)
(COND ((AND #(PDLLOCP LY)
(PROG2 NIL T
(SETQ TEMP (CDDDR (LEVEL TAG)))
(COND ((NOT #(NUMPDLP LY))
(SETQ N (LENGTH (CAR TEMP)) TEMP REGPDL))
((NOT #(FLPDLP LY))
(SETQ N (LENGTH (CADR TEMP)) TEMP FXPDL))
(T (SETQ N (LENGTH (CADDR TEMP)) TEMP FLPDL))))
(> LY (CONVNUMLOC (SETQ N (- N (LENGTH TEMP)))
(AND (NOT (REGADP LY)) TYPY))))
(SETQ LY (COND ((NULL TYPY) (FRAC5))
(((LAMBDA (TAKENAC1) (FREENUMAC)) AC))))
(LOADAC Y/' LY NIL)
(RSTD TAG AC LY))
((AND (RSTD TAG AC 0) (NOT (PLUSP N)))
(SETQ LY (ILOC2 (VARBP (CAR Y/')) Y/' TYPY))))
(REMOVE Y/'))
((NULL TAG)
(REMOVE Y/')
(AND (OR (EQ (PROG2 (FIND ARGNO) (CPUSH1 ARGNO NIL LY)) 'PUSH)
(EQ (PROG2 (FIND AC) (CPUSH1 AC NIL LY)) 'PUSH))
#(PDLLOCP LY)
(SETQ LY (ILOC2 (VARBP (CAR Y/')) Y/' TYPY)))))
(SETQ TEMP (COND (#(EQUIV F TAG) '(CAMN)) (T '(CAME))))
(COND (#(NUMACP AC) (OUT3 TEMP AC LY))
((OUT1 (CAR TEMP) AC LY)))
(AND TAG (OUTJ0 'JUMPA 0 TAG T NIL))))
(DEFUN NUMODIFY (X TYPX)
(COND ((NULL TYPX) NIL)
(T (SETQ X (ILOCMODE X 'FREENUMAC TYPX))
(AND (NUMBERP X)
#(NUMACP X)
((LAMBDA (ACX) (AND ACX (RPLACA ACX TYPX))) #(ACSMODESLOT X)))
X)))
(DEFUN COMERSET (ERSTP Y)
((LAMBDA (ARGNO TAG FLAG RSL V GOBRKL)
(AND ERSTP (LOADAC (COMP FLAG) 1 NIL))
(CLEARACS 2 T NIL)
(CLEARNUMACS)
(AND (NOT ERSTP) #(OUTFS 'MOVEI 1 FLAG))
#(OUTFS 'MOVEI 2 TAG)
(OUTPUT (COND (ERSTP '(JSP TT ERSETUP))
('(JSP TT (ERSETUP -1)))))
(DO I LERSTP+1 (SUB1 I) (ZEROP I)
#(PUSH '(NIL . TAKEN) REGPDL))
(SETQ RSL (SLOTLISTCOPY))
(SETQ GOBRKL (CONS (CONS (COND (ERSTP 'ERRSET) ('CATCH)) RSL) GOBRKL))
; VALUE FROM ERRSET WILL BE IN 1 SINCE IT IS OF FORM (NCONS FOO)
(SETQ V (COMP0 (CAR Y)))
(AND (NOT ERSTP)
(COND (EFFS (REMOVE V))
((NOT (EQUAL 1 (ILOC0 V NIL)))
(LOADAC V 1 T) ;BUT CATCH ISN'T ALWAYS
(RPLACA REGACS (SETQ V (LIST (GENSYM)))) ;SO LUCKY, SO PUT IT IN 1
#(PUSH V LDLST))))
(RESTORE RSL)
(AND (OR (CLEARVARS) (CLEARNUMACS))
(BARF NIL |LOSE LOSE - COMERSET|))
(OUTPUT (COND (ERSTP '(JRST 0 ERUNDO))
(T (OUTPUT '(MOVEI 2 'NIL))
'(JRST 0 (ERUNDO -1)))))
(SHRINKPDL LERSTP+1 NIL)
(OUTPUT TAG)
(AND (NOT EFFS) (REMOVE V))
V)
1 (GENSYM) (CADR Y) NIL NIL GOBRKL))
(DEFUN COMFIXFLT (ITEM MODE) ;MODE IS ALWAYS EITHER "FIXNUM" OR "FLONUM"
(COND ((EQ (CAR ITEM) 'QUOTE)
(WARN ITEM |QUOTE STUFF IN COMFIXFLT - SHOW THIS TO JONL|)
(REMOVE ITEM)
((LAMBDA (TYPE)
(COND ((MEMQ TYPE '(FIXNUM BIGNUM))
(COND ((EQ MODE 'FIXNUM)
(COND ((EQ TYPE 'BIGNUM)
(PDERR (CADR ITEM) |TOO BIG TO BE FIXNUM|)
(SETQ ITEM '0)))
ITEM)
((LIST 'QUOTE (FLOAT (CADR ITEM))))))
((EQ MODE 'FLONUM) ITEM)
((LIST 'QUOTE (FIX (CADR ITEM))))))
(TYPEP (CADR ITEM))))
(T (LOADAC ITEM #(NUMVALAC) NIL)
(COND ((EQ MODE 'FIXNUM) (CPUSH ##(1+ (NUMVALAC))) (RPLACA (CDR NUMACS) NIL)))
(OUTPUT (COND ((EQ MODE 'FIXNUM) '(JSP T IFIX)) ('(JSP T IFLOAT))))
(RPLACA ACSMODE MODE) ;(SETMODE ACSMODE MODE)
(CAR (RPLACA NUMACS (LIST (GENSYM))))))) ;(CONT #(NUMVALAC) (LIST (GENSYM)))
(DEFUN COMGO (Y)
(COND ((ATOM (CAR Y))
(COMGORET (ADR (CAR Y)) 0))
(T (CPVRL)
(LOADAC (COMP1 (CAR Y)) 1 T)
(COMGORET (GENTAG VGO 'VGO) 1))))
(DEFUN COMGORET (TAG AC)
(CPVRL)
(CLEARVARS)
(COND ((EASYGO) (OJRST TAG AC))
(T (CLEARNUMACS)
((LAMBDA (L LDLST CNT)
(MAPC '(LAMBDA (Y) (AND (EQ (CAR Y) 'UNBIND)
(CDR Y)
(SETQ CNT (CDR Y))))
GOBRKL)
(MAPC '(LAMBDA (Y)
(COND ((EQ (CAR Y) 'UNBIND) (OUTPUT '(PUSHJ P UNBIND)))
(T (RESTORE (CDR Y))
(OUTPUT (COND ((EQ (CAR Y) 'ERRSET) '(JSP T GOBRK))
('(JSP T (GOBRK -1)))))
(SHRINKPDL LERSTP+1 NIL))))
GOBRKL)
(COND ((NULL L-END-CNT))
((> L-END-CNT CNT) (SETQ CNT L-END-CNT)))
(OJRST TAG AC)
(SLOTLISTSET L))
(SLOTLISTCOPY) PROGP CNT))))
(DEFUN COMHAULONG (Y)
((LAMBDA (ARGNO ACX EFFS)
(LOADAC (COMP0 (CADR Y)) ARGNO NIL)
(SETQ ACX (COND ((= ARGNO #(NUMVALAC)) (+ 2 #(NUMVALAC)))
(#(NUMVALAC))))
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'MOVE)
(FIXP (CADR LOUT))
(= (CADR LOUT) ARGNO))
(SETQ LOUT (CONS 'MOVM (CDR LOUT))))
(#(OUTFS 'MOVMS 0 ARGNO)))
(CLEARNUMACS)
(MAPC 'OUTPUT
(COND ((AND (= ACX #(NUMVALAC)) (= ARGNO (1+ #(NUMVALAC))))
##(SUBLIS (LIST (CONS 'TT (NUMVALAC)) (CONS 'D (1+ (NUMVALAC))) (CONS 'R (+ 2 (NUMVALAC))))
''((MOVEI TT 36.) (JFFO D (* 2)) (TDZA TT TT) (SUBI TT 0 R))))
((AND (= ACX (+ 2 #(NUMVALAC))) (= ARGNO #(NUMVALAC)))
##(SUBLIS (LIST (CONS 'TT (NUMVALAC)) (CONS 'D (1+ (NUMVALAC))) (CONS 'R (+ 2 (NUMVALAC))))
''((MOVEI R 36.) (JFFO TT (* 2)) (TDZA R R) (SUBI R 0 D))))
((BARF (LIST ARGNO ACX) |COMHAULONG|))))
(SETMODE ACX 'FIXNUM)
(CAR (CONT ACX (LIST (GENSYM)))))
(COND ((= ARGNO #(NUMVALAC)) (1+ #(NUMVALAC)))
(#(NUMVALAC)))
NIL
NIL))
;;; CHART OF HOW COMGRTLSP WORKS, USING LESSP FOR EXAMPLE
;;; (LESSP A B), WHICH IS NOT 2LONG, AND
;;; (LESSP A B C D), WHICH IS 2LONG
;;; P1 IS THE COMPARISON BETWEEN A AND B, P2 BETWEEN B AND C,
;;; P3 BETWEEN C AND D. IN THE NORMAL SENSE OF THE TEST,
;;; THE RESULT IS EITHER A JUMP TO A TAG, OR A SKIP OF ONE LOC.
;;; IN THE INVERTED SENSE, THE LOGICAL SENSE OF THE TEST IS
;;; COMPLEMENTED. THE ARGUMENT "F" IS NON-NIL FOR THE NORMAL SENSE.
;;; EXAMPLES FOR THE 2LONG CASE FOLLOW. AFTER IT ARE THE
;;; EXAMPLES FOR THE NOT-2LONG CASE.
;;; WHEN TAG IS SUPPLIED, AND THERE IS NO LEVEL PROBLEM WITH IT
;;; NORMAL INVERTED
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST TAG
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST TAG
;;; |CAIGE| P3 CAIL P3
;;; JRST TAG JRST TAG
;;; LOSE: . . .
;;; WHEN TAG IS SUPPLIED, AND THERE IS A LEVEL PROBLEM
;;; NORMAL INVERTED
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST WIN
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST WIN
;;; CAIL P3 |CAIGE| P3
;;; JRST LOSE JRST LOSE
;;; [PDL CORRECTIONS] WIN: [PDL CORRECTIONS]
;;; JRST TAG JRST TAG
;;; LOSE: ... LOSE: . . .
;;; WHEN NO TAG IS SUPPLIED
;;; NORMAL INVERTED
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST WIN
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST WIN
;;; CAIL P3 CAIL P3
;;; LOSE: . . . WIN: SKIPA
;;; FOR ALL CASES WHICH ARE NOT 2LONG
;;; WITH TAG, NORMAL WITH TAG, INVERTED
;;; ---------------- --------------
;;; |CAIGE| P1 CAIL P1
;;; JRST TAG JRST TAG
;;; NO TAG, NORMAL NO TAG, INVERTED
;;; ---------------- --------------
;;; CAIL P1 |CAIGE| P1
(DEFUN COMGRTLSP (EXP TAG F)
(PROG (ARGL TYPEL MODE ARG1 ARG2 AC AD OP BTAG CTAG B2F SAVE FL 2LONG)
(SETQ TYPEL (COND ((NULL (CADR EXP)) (SETQ OP 'FIXNUM) '(NIL))
((NOT (MEMQ (CADR EXP) '(FIXNUM FLONUM))) (CADR EXP))
((NCONS (SETQ OP (CADR EXP))))))
(SETQ ARGL ((LAMBDA (ARGNO EFFS)
(MAPCAR '(LAMBDA (X)
(SETQ SAVE (COMP0 X))
(NUMODIFY SAVE OP)
SAVE)
(CDDR EXP)))
#(NUMVALAC) NIL))
(SETQ 2LONG (CDDR ARGL))
(COND ((AND TAG
(NOT 2LONG)
(OR (Q0P (SETQ ARG1 (CAR ARGL)))
(Q0P (SETQ ARG2 (CADR ARGL)))))
(SETQ OP (COND ((EQ (CAR EXP) 'LESSP) 'JUMPL)
((EQ (CAR EXP) 'GREATERP) 'JUMPG)
((GO BARF))))
(SETQ ARG2 (COND (ARG2 (REMOVE ARG2) ARG1)
(T (SETQ OP (GET OP 'COMMU))
(REMOVE ARG1)
(CADR ARGL))))
(OUTJ (COND (F OP) ((GET OP 'CONV)))
(LOCINNUMAC0 ARG2 0 NIL 'REMOVE)
TAG)
(RETURN T)))
(SETQ MODE (CAR TYPEL) ARG1 (CAR ARGL))
(SETQ OP (COND ((EQ (CAR EXP) 'LESSP) 'CAML)
((EQ (CAR EXP) 'GREATERP) 'CAMG)
((GO BARF))))
(SETQ BTAG (COND ((NOT 2LONG)
(AND #(EQUIV TAG F)
(SETQ OP (GET OP 'CONV)))
TAG)
((PROG2 (FREEIFYNUMAC) (NULL TAG)) (SETQ CTAG (LEVELTAG)))
(T (SETQ CTAG (COND ((SETQ B2F (BADTAGP TAG)))
((LEVELTAG))))
(COND ((AND (NULL F) (NULL B2F)) TAG) (CTAG)))))
(DO ((ARGL (CDR ARGL) (CDR ARGL)))
((NULL ARGL))
(SETQ ARG2 (CAR ARGL) TYPEL (OR (CDR TYPEL) TYPEL))
(COND ((NOT (EQ MODE (CAR TYPEL)))
(COND ((EQ MODE 'FIXNUM)
(SETQ ARG1 (COMFIXFLT ARG1 (SETQ MODE 'FLONUM))))
((SETQ ARG2 (COMFIXFLT ARG2 'FLONUM))))))
(COND ((AND (NOT #(ACLOCP (SETQ AD (ILOCMODE ARG1 'FREENUMAC MODE))))
(PROG2 (SETQ SAVE (ILOCMODE ARG2 'FREENUMAC MODE)) T)
(COND ((AND (NUMBERP SAVE) #(NUMACP SAVE)) (REMOVE ARG2) T)
((EQ (CAR ARG1) 'QUOTE)
(SETQ SAVE (LOCINNUMAC ARG2 0))
T)))
(SETQ AC SAVE FL T SAVE ARG1))
(T (COND ((AND (NUMBERP AD) #(NUMACP AD))
(SETQ AC AD)
(REMOVE ARG1))
((SETQ AC (LOCINNUMAC0 ARG1 0 NIL 'REMOVE))))
((LAMBDA (TAKENAC1) (SETQ AD (ILOCMODE ARG2 'FREENUMAC MODE))) AC)
(SETQ SAVE ARG2 FL NIL)))
(COND ((OR (NULL 2LONG) (CDR ARGL))) ;FIX UP LAST CLAUSE OF 2LONGS
((NULL TAG) (SETQ BTAG NIL)) ;FOR REVERSAL OF CONDITION
((AND F (NULL B2F)) (SETQ BTAG TAG OP (GET OP 'CONV)))
((AND (NULL F) B2F)
(SETQ BTAG (SETQ CTAG (LEVELTAG)) OP (GET OP 'CONV))))
(COND (TAG (AND (RSTD BTAG AC 0)
(NUMBERP AD)
(SETQ AD (ILOC2 (VARBP (CAR SAVE)) SAVE MODE)))
(REMOVEB SAVE)
(CLEARVARS))
(T (REMOVE SAVE)
(AND (OR (EQ (PROG2 (FIND ARGNO) (CPUSH1 ARGNO NIL AD)) 'PUSH)
(EQ (PROG2 (FIND AC) (CPUSH1 AC NIL AD)) 'PUSH))
#(PDLLOCP AD)
(SETQ AD (ILOC2 (VARBP (CAR SAVE)) SAVE MODE)))))
(OUT3 (ASSQ (COND ((NULL FL) OP) ((GET OP 'COMMU)))
'((CAML) (CAMLE) (CAMG) (CAMGE)))
AC
AD)
(AND BTAG (OUTJ0 'JUMPA 0 BTAG T 0))
(SETQ ARG1 ARG2))
(COND (CTAG (COND (B2F (AND (NULL F) (OUTTAG B2F))
(OUTJ0 'JRST 0 TAG T 0)))
(OUTTAG CTAG)
(AND (NULL TAG) (NULL F) (OUTPUT '(SKIPA)))))
(RETURN NIL)
BARF (BARF EXP |THIS IS NO FUN - COMGRTLSP|)))
(DEFUN COMLAM (X Y)
;;; X = (LAMBDA COMPLEXITY SETQLIST MODELIST LAMVARS BODY ENDCOUNT LAMUNSF NLNVTHTBP)
((LAMBDA (OLVRL BVARS GOBRKL MODELIST LARG SPFL LMRSL MODE TEM PNOB CONDPNOB LLL)
(CLEAR (CADDR X) NIL) ;CHECK OUT THE SETQ-LIST
((LAMBDA (CNT)
(COND ((MEMQ PROGN (CADDR X)) (CLEARACS0 NIL))
(T (CLEARVARS))))
(CADDR LLL)) ;BUT NOT VARS THAT WILL GO OUT OF DATE DURING LAMBDA
(SETQ LMRSL (SLOTLISTCOPY)) ;REMEMBER HOW DEEP THE SLOTLIST IS
(CNPUSH (CAR (CDDDDR LLL)) NIL) ;PUSH NLNVTHTBP
(AND Y ;COMPUTE UP ARGLIST, ILOC ITEMS,
(PROG (SPLL1 RGLLL RGLLM LMQL ITEM VMS N LARGSLOTP) ;KEEP TRACK OF QUOTE STUFF FOR
(SETQ VMS (MAPCAR 'VARMODE (CAR LLL))) ;EFFICIENT BINDING, AND SEPARATE
(DO ((VAR (REVERSE (CAR LLL)) (CDR VAR)) ;OUT ITEMS FOR SPECIAL VARS
(TYPEL (REVERSE VMS) (CDR TYPEL))
(ACLQ T) ;HAC TO HELP FIND FREE ACS.
(ARGS (DO ((EFFS) (T1) (ARGNO 1) (ARGS) (TYPEL VMS (CDR TYPEL))
(Y Y (CDR Y)) (VAR (CAR LLL) (CDR VAR)))
((NULL Y) ARGS)
(COND ((AND (NOT (SETQ ITEM #(SPECIALP (CAR VAR))))
(CAR TYPEL))
#(PUSH (COMPW (CAR Y) NIL #(NUMVALAC)) ARGS)
(COMLOCMODE (CAR ARGS) 'FREENUMAC (CAR TYPEL) (CAR VAR)))
(T ((LAMBDA (OPNOB)
(SETQ PNOB (AND (NOT ITEM) (CAR VAR)) ;PNOB PROHIBITED ON SPECIAL VARS
T1 (COMP0 (CAR Y))
PNOB OPNOB))
PNOB)
(SETQ TEM (SHOULD-I-P2NUMCONS-P (CAR Y) (CAR VAR) ITEM T1 #(ILOCN T1)))
#(PUSH (OR TEM T1) ARGS))))
(CDR ARGS)))
((NULL VAR))
(SETQ SPFL #(SPECIALP (CAR VAR)))
(SETQ MODE (AND (NOT SPFL) (CAR TYPEL)))
(SETQ LARG (ILOCMODE (CAR ARGS) NIL MODE))
(REMOVE (CAR ARGS))
(SETQ LARGSLOTP (NUMBERP LARG))
(COND ((AND (NOT LARGSLOTP) (NULL (CDR LARG)))
(COND ((AND SPFL (NOT (QNILP (CAR LARG))) (NOT (ASSOC LARG LMQL)))
(COND ((NULL ACLQ) (SETQ N 0))
((NOT (ZEROP (SETQ N (FRACB)))))
((EQ ACLQ 'CLEARVARS) (SETQ ACLQ NIL))
(T (CLEARVARS) (SETQ ACLQ 'CLEARVARS N (FRACB))))
(COND ((ZEROP N)
(OPUSH LARG (SETQ ITEM (CONS (CAR VAR) 'TAKEN)) MODE))
(T #(PUSH (CONS LARG N) LMQL)
(OUT1 'MOVE N LARG)
(CONT N (CONS LARG 'TAKEN))
(SETQ ITEM (CONS (CAR VAR) LARG)))))
(T (SETQ ITEM (CONS (CAR VAR) LARG)))))
(T (COND ((COND (LARGSLOTP (COND ((AND (NOT MODE) (NOT (REGADP LARG))) NIL)
(T (FIND LARG)
(AND (> LARG 0) SPFL (CPUSH1 LARG T NIL))
(NOT (DVP1 SLOTX LARG)))))
((AND SPFL (NOT (ZEROP (SETQ N (LOCINAC (CAR ARGS) 'FRACB T NIL)))))
(SETQ LARG N) T)
(T (AND (NOT (EQ (CAR LARG) 'SPECIAL))
(BARF LARG |NOT LARGSLOTP - COMLAM|))
(OPUSH LARG NIL MODE)
(SETQ LARG (CONVNUMLOC 0 MODE)) T))
(CONT LARG (SETQ ITEM (CONS (CAR VAR) 'TAKEN))))
(T (SETQ ITEM (CONS (CAR VAR) (CONS 'ILOC0 (CAR ARGS))))
#(PUSH (CAR ARGS) LDLST)))))
(COND (SPFL #(PUSH ITEM SPLL1))
(T #(PUSH (CAR TYPEL) RGLLM) #(PUSH ITEM RGLLL))))
(SETQ SPFL (PROGHACSET SPLL1 (CADR LLL)))
; CAUSE THE LAMBDA BIND ING S TO HAPPEN
(DO ((VAR RGLLL (CDR VAR)) (TYPEL RGLLM (CDR TYPEL)))
((NULL VAR))
(COND ((EQ (CDAR VAR) 'TAKEN) ;(VAR . TAKEN)
(RPLACD (CAR VAR) NIL))
((AND (NULL (CDDAR VAR)) ;(VAR . ((QUOTE NIL)))
(OR (QNILP (CADAR VAR)) ;(VAR . ((QUOTE 0)))
(AND (CAR TYPEL)
(Q0P (CADAR VAR)))))
#(PUSH (CAAR VAR) OLVRL))
(T (SETQ MODE (CAR TYPEL))
(SETQ TEM (COND ((EQ (CADAR VAR) 'ILOC0) ;(VAR . (ILOC0 . QUANT))
#(ILOCF (CDDAR VAR)))
(T (CDAR VAR)))) ;(VAR . ((QUOTE THING)))
(COND ((AND (NOT MODE) (NOT (REGADP TEM)))
(SETQ N (FRACB))
(COND ((ZEROP N) (CLEARVARS) (SETQ N (FRACB))))
(AND (ZEROP N) (BARF REGACS |COMLAM ACS LOSSAGE|))
(AND (NOT (MEMQ (CAAR VAR) UNSFLST))
(BARF (LIST (CAAR VAR) TEM) |UNSAFE VAR - COMLAM|))
(MAKEPDLNUM (CDDAR VAR) N)
(CONT N (LIST (CAAR VAR))))
(T (AND (EQ (CADAR VAR) 'ILOC0) (REMOVEB (CDDAR VAR)))
(OPUSH TEM (LIST (CAAR VAR)) MODE))))))
; FOR BIND ING TO A SPECIAL VAR, THE ITEM MUST BE IN AN ACCUMULATOR
; AND A CALL TO THE PSEUDO FUNCTION SPECBIND IS MADE
(COND (SPLL1 (CPUSH (+ #(NUMVALAC) 2)) ;SPECBIND USES ACC R [= 11 = TT+2]
(OUTPUT '(JSP T SPECBIND))
(DO VAR SPLL1 (CDR VAR) (NULL VAR)
(DO Z REGACS (CDR Z) (NULL Z)
(AND (CAR Z)
(EQ (CAAR Z) (CAAR VAR))
(OR (NULL (CDAR Z))
(EQ (CDAR Z) 'DUP))
(RPLACA Z NIL)))
(SETQ LARG
(COND ((EQ (CDAR VAR) 'TAKEN)
(RPLACD (CAR VAR) CNT)
(SETQ LARG (ILOC1 T (CAR VAR) NIL))
(AND (NOT (NUMBERP LARG)) (BARF NIL |LOSE LOSE - COMLAM|))
LARG)
((QNILP (CADAR VAR)) NIL)
((EQ (CADAR VAR) 'ILOC0)
(SETQ TEM (PROG2 NIL
#(ILOCF (SETQ TEM (CDDAR VAR)))
(REMOVEB TEM)))
(COND (#(PDLLOCP TEM)
(AND (NOT (DVP TEM)) (RPLACA SLOTX NIL))
TEM)
(T (BARF TEM |WHERE AM I - COMLAM|))))
((SETQ LARG (ASSOC (CDAR VAR) LMQL))
(CONT (CDR LARG) (LIST (CAAR VAR)))
(CDR LARG))
(T (BARF NIL |LOSE LOSE - COMLAM|))))
(OSPB LARG (CAAR VAR)))
(MAPC 'CARCDR-FREEZE SPLL1 (CAR COMAL)) ;(CAR COMAL) HAS INFINITE LIST OF NILS
#(PUSH (CONS 'UNBIND (CADDR LLL)) GOBRKL)))))
; EXECUTE LAMBDA BODY AND RESTORE SLOTLIST
(SETQ BVARS (APPEND (CAR LLL) BVARS))
(SETQ LARG ((LAMBDA (PNOB L-END-CNT) (COMP0 (CADR LLL)))
CONDPNOB (OR L-END-CNT (CADDR LLL)))
TEM NIL)
(COND ((AND (NOT EFFS)
(NOT (EQ (CAR LARG) 'QUOTE))
(PROG2 (SETQ TEM (MEMQ (CAR LARG) (CAR LLL)) Y #(ILOCN LARG))
(COND ((NOT #(ACLOCP Y)) (SETQ Y ARGNO) T)
(TEM))))
(LOADAC LARG Y (OR TEM (NOT CONDPNOB)))
(AND (OR TEM (NOT (EQUAL LARG (CONTENTS Y))))
(CONT Y (SETQ LARG (LIST (GENSYM)))))
#(PUSH LARG LDLST)))
(COND ((AND (L/.LE/. (CAR (SETQ TEM (CDDDR LMRSL))) REGPDL)
(L/.LE/. (CADR TEM) FXPDL)
(L/.LE/. (CADDR TEM) FLPDL))
(RESTORE LMRSL))
(T (DO Z '(REGACS NIL NUMACS NIL REGPDL 0 FXPDL ##(FXP0) FLPDL ##(FLP0))
(CDDR Z)
(NULL Z)
(DO ((SLOTL (SYMEVAL (CAR Z)) (CDR SLOTL)) (I 0 (1+ I)))
((NULL SLOTL))
(AND (CAR SLOTL)
(MEMQ (CAAR SLOTL) (CAR LLL))
(RPLACA SLOTL NIL))))))
(SETQ CNT (1+ CNT))
(COND (SPFL (OUTPUT '(PUSHJ P UNBIND))))
(DIDUP (CADDR X))
(CLEANUPSPL NIL)
(REMOVE LARG)
LARG)
OLVRL BVARS GOBRKL (CADDDR X) NIL NIL NIL NIL NIL NIL
PNOB (CDDDDR X)))
(DEFUN COMLC (X Y ITEMFL)
; COMPILE A CALL TO AN L FORM - P1 PLACES L TYPE CALLS WITHIN
; THE SCOPE OF AN INTERNAL LAMBDA APPLICATION LIKE
; ((LAMBDA NIL (LCALL * *))
; THUS A CLEAR IS DONE BY COMLAM)
((LAMBDA (OARGNO ARGNO OPNOB PNOB)
(PROG (NARGS Z TAG LZ RSL PDLTP)
(SETQ NARGS (LENGTH Y))
(COND ((ZEROP NARGS)
(CLEARACS1 X 'GENSYM) ;REMEMBERING THAT COMLAM CLEARVARSD
(OUTPUT '(MOVEI T 0))
(SETQ ARGNO OARGNO PNOB OPNOB)
(RETURN (COML1 X 'CALL))))
(CLEARACS ##(+ (NACS) (NUMNACS)) NIL 'GENSYM) ;REMEMBERING THAT COMLAM CLEARVARSD
(SETQ TAG (RETURNTAG))
(SETQ RSL (APPEND '(NIL NIL NIL) (SETQ PDLTP (LIST (APPEND REGPDL NIL)))))
(DO Y Y (CDR Y)(NULL Y)
(SETQ LZ #(ILOCREG (SETQ Z (COND (ITEMFL (CAR Y))
(T (COMPW (CAR Y) NIL 1))))
1))
(RESTORE RSL)
(COND ((NOT (REGADP LZ)) (MAKEPDLNUM Z (SETQ LZ (FRACB))))
((REMOVEB Z)))
(COND ((AND #(ACLOCP LZ)
(NOT ATPL)
(EQ (CAR LOUT) 'SUB)
(EQ (CADR LOUT) 'P)
(EQUAL LOUT '(SUB P (% 0 0 1 1))))
(SETQ LOUT (SETQ ATPL 'FOO))
(OUT1 'MOVEM LZ 0)
#(PUSH '(NIL . TAKEN) REGPDL))
(T (AND #(PDLLOCP LZ) (SETQ LZ (ILOC0 Z NIL)))
(OPUSH LZ '(NIL . TAKEN) NIL)))
(RPLACA PDLTP (CONS '(NIL . TAKEN) (CAR PDLTP))))
(AND (CLEARACS0 NIL) ;CHECK FOR IMPORTIENT THINGS
(BARF NIL |TOO MUCH VALUE - COMLC|)) ;BEING INADVERTENTLY LEFT IN ACS
(CLEARACS1 X NIL) ;CLOBBER OUT THE ACS TO BE USED
#(OUTFS 'MOVNI T NARGS)
(SETQ ARGNO OARGNO PNOB OPNOB)
(SETQ Z (COML1 X 'JCALL))
(OUTPUT TAG)
(SHRINKPDL (1+ NARGS) NIL)
(RETURN Z)))
(COND ((AND (EQ (CAR X) COMP) (EQ (CADR X) 'FUNCALL)) 1)
((OR PNOB #(NUMACP ARGNO)) ARGNO)
(1))
1
PNOB
T))
(DEFUN COML1 (X OP)
(COND ((EQ (CAR X) COMP)
((LAMBDA (LOC)
(REMOVEB (CADDR X))
(COND ((EQ (CADR X) 'FUNCALL)
(OUT1 (COND ((EQ OP 'CALL) 'CALLF) ('JCALLF))
16
LOC)
1)
((NULL (CADR X))
(COND ((EQ OP 'CALL) (OUT1 '(PUSHJ) 'P LOC)) ((OUT1 '(JRST) 0 LOC)))
1)
(T (OUT1 'MOVE #(NUMVALAC) LOC)
(OUTPUT (COND ((EQ OP 'CALL) '(PUSHJ P @ 1 ##(NUMVALAC)))
('(JRST 0 @ 1 ##(NUMVALAC)))))
(RPLACA ACSMODE (CADR X))
#(NUMVALAC))))
#(ILOCF (CADDR X))))
((OUTFUNCALL OP 16 X))))
(DEFUN COMLOCMODE (ITEM FUN MODE VAR)
((LAMBDA (LARG OPPOSER)
(SETQ OPPOSER (COND ((NOT (NUMBERP LARG))
(COND ((EQ (CAR LARG) 'SPECIAL) (VARMODE (CADR LARG)))
((EQ (CAAR LARG) 'QUOTE)
(CAR (MEMQ (TYPEP (CADAR LARG)) '(FIXNUM FLONUM))))))
(#(NUMACP LARG)
(COND ((GETMODE0 LARG T NIL))
(T (SETMODE LARG MODE) MODE)))
(#(NUMPDLP LARG) (COND (#(FLPDLP LARG) 'FLONUM) ('FIXNUM)))
((GETMODE LARG))
(T MODE)))
(AND OPPOSER
(NOT (EQ MODE OPPOSER))
(DBARF (LIST (CONS VAR MODE) (CONS ITEM OPPOSER))
|BINDING NUMBER VARIABLE TO QUANTITY OF WRONG TYPE|))
LARG)
#(ILOCNUM ITEM FUN)
NIL))
;;; DONT TRY TO SUBSTITUTE ILOC1 OR ILOC2 FOR THIS ILOCNUM -
;;; YOU HAVE TO SATISFY CONFLICTS BETWEEN THE REGWORLD AND NUMWORLD
(DEFUN COMNULL (Y)
((LAMBDA (LY TEM FL)
(COND ((NOT EFFS)
(COND ((CCHAK-BOOL1ABLE Y NIL))
(T (SETQ TEM (COMP0 Y) LY #(ILOCREG TEM ARGNO)
FL (NUMBERP LY))
(REMOVEB TEM)
(FIND ARGNO)
(AND (CPUSH1 ARGNO NIL LY)
FL
#(REGPDLP LY)
(SETQ LY (ILOC0 TEM NIL)))
(COND ((AND FL (> LY 0) (< LY #(NUMVALAC)))
(OUTPUT (CADDR (BOLA LY))))
(T (OUT1 'SKIPE 0 LY)))))
(BOOLOUT NIL NIL))
((COMPE Y))))
NIL NIL NIL))
(DEFUN COMPROG (Y)
; TYPICAL INPUT Y = (COMPLEXITY SETQLIST GOLIST MODELIST PROGVARS
; PROGBODY PROGUNSF NLNVTHTBP)
(AND (NULL SFLG) (CLEAR (CADR Y) T))
((LAMBDA (PVR OPVRL PROGPNOB PROGTYPE SPFL OEFFS ARGNO EFFS EXLDL PROGP)
(PROG (EXIT EXITN LPRSL PRSSL GOBRKL VGO GL PVRL MODELIST PNOB FL TEM LY L-END-CNT)
(SETQ MODELIST (CAR (SETQ LY (CDDDR Y))))
(MAPC '(LAMBDA (X)
(AND #(SPECIALP X)
(PROG2 (COND ((NULL SPFL)
(SETQ SPFL T)
(CPUSH ##(+ (NUMVALAC) 2))
(OUTPUT '(JSP T SPECBIND))))
(OSPB NIL X))))
(CADR LY))
(COND (SFLG (CLEAR (CADR Y) T) (SETQ SFLG NIL)))
(SETQ CNT (ADD1 CNT))
(SETQ GL (CADDR Y))
(SETQ PVRL (MAPCAN '(LAMBDA (X) (AND (NOT #(SPECIALP X)) (LIST X)))
(CAR (SETQ LY (CDR LY)))))
(CNPUSH (CADDR (SETQ LY (CDR LY))) NIL) ;PUSH NLNVTHTBP
(AND (MEMQ PROGN (CADR Y)) (SETQ PROGPNOB NIL)) ;IF PROGUNSF = T, THEN FLUSH PNOB
(MAP '(LAMBDA (X)
(SETQ CNT (ADD1 CNT))
(COND ((ATOM (CAR X))
(COND ((SETQ TEM (ADR (CAR X)))
(CLEARACS0 T)
(CPVRL)
(RESTORE PRSSL)
(COND ((NOT ATPL) (PUTPROP TEM LOUT 'PREVI)))
(OUTTAG0 TEM)
(CLEANUPSPL NIL))))
((AND (NULL (CDR X)) (EQ (CAAR X) 'RETURN))
(COND ((OR (NULL (CDAR X)) (QNILP (CADAR X)))
(GENTAG EXITN 'EXITN))
(T (GENTAG EXIT 'EXIT)
((LAMBDA (PNOB)
(LOADAC (COMPW (CADAR X) NIL PVR)
PVR
(NOT PROGPNOB)))
PROGPNOB)
(COND (EXITN (OJRST EXIT PVR)))))
(SETQ FL T))
(T (COND ((EQ (CAAR X) 'COND)
(AND (MEMQ GOFOO (CADDAR X)) (RESTORE PRSSL))
(COMCOND (CDAR X)
NIL
NIL
(AND (CDR X)
(EQ (CAADR X) 'GO)
(ATOM (SETQ TEM (CADADR X)))
(ADR TEM))))
(T (COMPW (CAR X) T 1))))))
(CAR LY))
(COND ((AND (NULL LPRSL)
(COND ((NULL EXIT)
(AND (NOT OEFFS) (CMPRGLDNIL T))
T)
((NULL EXITN))))
(CLEANUPSPL NIL)
(SETQ CNT (+ CNT 2))
(CLEARACS0 T))
(T (SETQ FL (NOT (OR FL (AND (NOT ATPL) (MEMQ (CAR LOUT) '(JRST JUMPA))))))
(OUTTAG EXITN)
(AND (NOT OEFFS) (CMPRGLDNIL FL))
(OUTTAG EXIT)
(CLEARACS0 T)
(OR EXIT EXITN (CLEANUPSPL NIL))
(SETQ CNT (+ CNT 2))))
(COND (SPFL (CPUSH ##(+ (NUMVALAC) 2)) (OUTPUT '(PUSHJ P UNBIND))))
(DIDUP (CADR Y))
(COND (VGO (SETQ VGOL (CONS (CONS VGO (GCDR 'CAAR GL)) VGOL))))
(RETURN PROGTYPE)))
(COND ((OR (AND (NOT EFFS) (NOT (= ARGNO 1)) (< (CAR Y) 2))
#(NUMACP ARGNO))
ARGNO)
(1))
(LJOIN OPVRL PVRL)
PNOB NIL SFLG EFFS 1 1 LDLST LDLST))
(DEFUN COMPROGN (L OEFFS)
(AND L (DO ((Z L (CDR Z)) (EFFS T))
((NULL (CDR Z)) (SETQ EFFS OEFFS) (COMP0 (CAR Z)))
(COMP0 (CAR Z)))))
(DEFUN CMPRGLDNIL (FL)
(AND (OR FL EXITN)
(COND (#(NUMACP PVR) (LOADAC '(QUOTE 0) PVR NIL))
((NOT (QNILP (CONTENTS PVR))) (LOADAC '(QUOTE NIL) PVR T)))))
(DEFUN COMRETURN (Y)
((LAMBDA (ARGNO)
(COND ((QNILP (CAR Y))
(COMGORET (GENTAG EXITN 'EXITN) 0))
(T ((LAMBDA (PNOB) (LOADAC (COMPW (CAR Y) NIL PVR) PVR (NOT PROGPNOB))) PROGPNOB)
(AND #(NUMACP PVR)
(SETQ Y (CAR #(ACSMODESLOT PVR)))
(COND ((NULL PROGTYPE) (SETQ PROGTYPE Y))
((NOT (EQ PROGTYPE Y)) (SETQ PROGTYPE 'FIXNUM))))
(COMGORET (GENTAG EXIT 'EXIT) PVR))))
PVR))
(DEFUN COMREMAINDER (ARGL)
(DO ((ARGNO #(NUMVALAC)) (TAKENAC1 TAKENAC1) (EFFS) (ARG1) (ARG2) (AC) (LARG) (SVSLT))
NIL
(SETQ ARG1 (COMP0 (CAR ARGL))
ARGNO #(NUMVALAC)
ARG2 (COMP0 (CADR ARGL)))
(SETQ TAKENAC1 (1- (+ #(NUMVALAC) #(NUMNACS))) AC (FREENUMAC))
(SETQ LARG #(ILOCNUM ARG1 #(NUMVALAC)))
(COND ((AND (NUMBERP LARG)
#(NUMACP LARG)
(< LARG ##(1- (+ (NUMVALAC) (NUMNACS)))))
(REMOVEB ARG1)
(SETQ AC LARG))
((LOCINNUMAC ARG1 AC)))
(FIND AC)
(CPUSH1 AC NIL NIL)
(RPLACA SLOTX '(NIL . TAKEN))
(SETQ SLOTX (CDR (SETQ SVSLT SLOTX))) ;SETUP FOR ENTRY TO CPUSH1
(CPUSH1 (1+ AC) NIL NIL)
(SETQ LARG #(ILOCNUM ARG2 (1+ AC)))
(REMOVEB ARG2)
(OUT3 '(IDIV) AC LARG)
(SETQ LARG #(ACSMODESLOT AC))
(AND (NULL (CDR LARG)) (BARF AC |WHATS THIS AC DOING HERE -COMREMAINDER|))
(RPLACA LARG NIL) ;SETMODE AC NIL
(RPLACA (CDR LARG) 'FIXNUM) ;SETMODE AC+1 'FIXNUM
(RPLACA SVSLT NIL) ;CONT AC NIL
(RETURN (CAR (RPLACA (CDR SVSLT) (LIST (GENSYM)))))))
(DEFUN COMSHIFTS (OP ARGS)
((LAMBDA (EFFS ARGNO ARG1 ARG2 TAKENAC1)
(SETQ ARG1 (COMP0 (CAR ARGS)) ARG2 (COMP0 (CADR ARGS)))
(SETQ TAKENAC1 (LOCINNUMAC ARG1 0))
(SETQ ARG1 (COND ((EQ (CAR ARG2) 'QUOTE) (REMOVE ARG2) (CADR ARG2))))
(COND ((COND ((NULL ARG1) NIL)
((EQ OP 'FSC) (> ARG1 777777)) ;FSC N,LARGENUM LEAVES UNNORMALIZED
((= ARG1 0)))) ;LSH.ROT N,0 DOES NOTHING
(T (SETQ ARG2 (COND (ARG1 (LIST ARG1))
((LIST 0 (LOCINNUMAC ARG2 0)))))
(AND (NOT ARG1)
(EQ OP 'FSC)
#(OUTFS 'CAIG (CADR ARG2) 777777))
(OUTPUT (CONS OP (CONS TAKENAC1 ARG2)))))
(SETMODE TAKENAC1 (COND ((EQ OP 'FSC) 'FLONUM) ('FIXNUM)))
(CAR (CONT TAKENAC1 (LIST (GENSYM)))))
NIL #(NUMVALAC) NIL NIL 0))
(DEFUN COMRPLAC (FUN L VAL)
(PROG (X Y LX LY OCNT)
(CSLD NIL T NIL) ;GRABS IN ONLY THE CARCDR LOADINGS
(SETQ OCNT CNT)
((LAMBDA (PNOB EFFS ARGNO)
(SETQ X (COMP0 (CAR L)) Y (COMP0 (CADR L))))
NIL NIL 1)
(SETQ LX #(ILOCN X) LY #(ILOCF Y))
(AND (NOT (REGADP LX)) (PDERR (CONS FUN L) |CANT RPLACE NUMERIC DATA|))
(AND (OR (NOT (REGADP LY))
(AND (NOT (EQ (CAR Y) 'QUOTE)) (MEMQ (CAR Y) UNSFLST)))
#(PUSH (SETQ Y (P2NUMCONS Y LY)) LDLST))
(AND #(PDLLOCP LX)
(EQ (CDR (CONTENTS LX)) 'IDUP)
(PROG2 ((LAMBDA (CNT) (DIDUP (LIST (CAR X)))) OCNT)
(SETQ LX (ILOC0 X NIL))))
(COND ((AND (EQ FUN 'SETPLIST)
(OR (NOT (EQ (CAR X) 'QUOTE)) (NULL (CADR X))))
(REMOVEB X)
(SETQ OCNT (COND (#(ACLOCP LX) (CPUSH LX) LX)
((OR EFFS (DVP ARGNO)) #(FREAC))
(T ARGNO)))
(OUT1 'SKIPN OCNT LX)
#(OUTFS 'MOVEI OCNT 'NILPROPS)
#(PUSH (SETQ X (LIST (GENSYM))) LDLST)
(CONT (SETQ LX OCNT) X))
((SETQ OCNT NIL)))
(COND ((QNILP Y) (OUT1 (GET FUN 'INSTN) 0 LX))
(T (SETQ LY #(ILOCREG Y (COND ((AND (NULL EFFS) ;THIS IS JUST ILOCF
(AND (NUMBERP LX) (= LX 1)) ;EXCEPT WHEN RESULT
(= ARGNO 1)
(NULL VAL)) ;IS TO GO INTO 1
#(FREAC))
('FRAC1))))
(AND (NOT #(ACLOCP LY)) (LOADAC Y (SETQ LY (FRAC1)) T))
(OUT1 (GET FUN 'INST) LY (ILOC0 X NIL))))
(REMOVE X)
(REMOVE Y)
(CLEANUPSPL T) ;SO FORGET ABOUT ANY NASCENT CARCDRINGS
(COND ((AND OCNT (NOT EFFS))
#(OUTFS 'CAIN OCNT 'NILPROPS)
#(OUTFS 'MOVEI OCNT 0)))
(RETURN (COND (VAL Y) (X)))))
(DEFUN COMSETQ (Y)
(PROG (LARG HOME V Z TEM NLP MODE LARGSLOTP DOD CMPVL SPFL)
COMSQ1
(SETQ MODE (AND (NOT (SETQ SPFL #(SPECIALP (CAR Y)))) (VARMODE (CAR Y))))
(SETQ NLP (CDDR Y))
(SETQ HOME (ILOC0 (SETQ V (CONS (CAR Y) CNT)) MODE) TEM NIL)
(COND ((AND MODE
HOME
(SETQ TEM (NOT (ATOM (CADR Y))))
(SETQ Z (COND ((EQ (CAADR Y) 'ADD1) 'AOS)
((EQ (CAADR Y) 'SUB1) 'SOS)))
(AND (CDDR (CADR Y)) (NULL (CDDDR (CADR Y)))) ;LENGTH = 3
(EQ (CAR V) (CAR (CDDADR Y)))
(EQ (CADADR Y) 'FIXNUM)
(OR (NOT (ASSQ (CAR V) LDLST)) (NOT (DVP HOME)))
(NOT (REGADP HOME)))
(COND ((AND #(ACLOCP HOME) (CDR (CONTENTS HOME)))
(CPUSH1 HOME T NIL) ;SLOTX HAS STILL BEEN SETUP BY CONTENTS
(RPLACA SLOTX NIL) ;HENCE THIS BECOMES (CONT HOME NIL)
(SETQ HOME (ILOC2 T V 'FIXNUM))))
(CSQFREEZ (CAR V) '(REGACS NIL REGPDL 0) T MODE) ;REMEMBER, INCREMENTS CNT
(CARCDR-FREEZE (CAR V) NIL)
(ASIDE-FROM-FOO Z NLP HOME (CAR V) MODE) ;Z HAS INST, (CAR V) THE VAR'S NAME
(SETQ CNT (PLUS CNT 2))
(GO COMPS3)))
(COND ((AND TEM ;PREV VALUE IS
(SETQ TEM (CAADR Y)) ;(AND MODE HOME (NOT (ATOM (CADR Y))))
(MEMQ TEM '(PLUS TIMES DIFFERENCE *DIF))
(CDDDR (CADR Y)) ;TYPICAL Y = (N (PLUS FIXNUM N FOO))
(NULL (CDDDDR (CADR Y))) ; CHECK LENGTH[CADR[Y]] = 4
(CAR (SETQ Z (CDADR Y))) ;Z = (FIXNUM N FOO)
(ATOM (CAR Z))
(EQ (CAR Y) (CADR Z))
(SETQ Z (CADDR Z))
(COND ((NOT #(ACLOCP HOME)))
((EQ (CDR (CONTENTS HOME)) 'DUP)
(RPLACA SLOTX NIL))
((ATOM Z) NIL)
((NOT (EQ (CAR Z) CARCDR)))))
(COND ((MEMQ TEM '(*DIF DIFFERENCE))
(SETQ TEM 'PLUS)
(SETQ Z (LIST 'MINUS (CADADR Y) Z))))
(SETQ Y (LIST (CAR Y) (LIST TEM (CADADR Y) Z (CAR Y))))))
(SETQ CMPVL (COMPR (CADR Y) MODE EFFS (NOT SPFL)))
(SETQ LARG (COND (MODE (COMLOCMODE CMPVL 'ARGNO MODE (CAR Y)))
(T #(ILOCREG CMPVL (COND (NLP 'FRACF) ('ARGNO))))))
(AND (OR SPFL (NOT MODE))
(SETQ TEM (SHOULD-I-P2NUMCONS-P (CADR Y) (CAR Y) SPFL CMPVL LARG))
(SETQ CMPVL TEM LARG (COND ((EQ (CAR REGACS) TEM) 1) ((ILOC0 TEM NIL)))))
(SETQ LARGSLOTP (NUMBERP LARG))
(COND ((AND SPFL
(SETQ TEM (ASSQ (CAR Y) LDLST))
(NOT (NUMBERP (ILOC0 TEM MODE))))
(OPUSHS (CAR Y))
(SETQ SPLDLST (DELQ TEM SPLDLST))
(AND LARGSLOTP #(REGPDLP LARG) (SETQ LARG (1- LARG)))))
(REMOVEB CMPVL)
(COND ((AND MODE ;MODE=T => SPFL=NIL
LARGSLOTP
(NOT ATPL)
(AND (CDDDR LOUT) (NULL (CDDDDR LOUT))) ;LENGTH = 4
(SETQ TEM (GET (CAR LOUT) 'BOTH))
(NUMBERP (CADDR LOUT))
(= LARG (CADR LOUT))
(EQ (CADDDR LOUT) #(PDLAC MODE))
(EQUAL (SETQ Z (ILOC0 V MODE))
(CONVNUMLOC (CADDR LOUT) MODE))
(NOT (DVP (CADR LOUT)))
(OR (NOT (ASSQ (CAR Y) LDLST)) (NOT (DVP Z))))
(CONT (CADR LOUT) (CONS (CAR Y) 'DUP))
(RPLACA LOUT TEM)
(CSQFREEZ (CAR V) '(REGACS NIL REGPDL 0) T MODE)
(CARCDR-FREEZE (CAR V) NIL)
(SETQ CNT (1+ CNT))
(GO COMPS3)))
(SETQ V (CAR Y))
; SO FREEZE WORLD AT THIS POINT
(SETQ TEM (CSQFREEZ V
'(REGACS NIL NUMACS NIL REGPDL 0 FXPDL ##(FXP0) FLPDL ##(FLP0))
NIL
MODE))
(CARCDR-FREEZE V (CAR CMPVL))
(AND #(PDLLOCP LARG) (SETQ LARG (ILOC2 (VARBP (CAR CMPVL)) CMPVL (GETMODE LARG))))
(SETQ DOD (AND LARGSLOTP (DVP LARG)))
(SETQ HOME
(COND (SPFL) ;HOME = NIL =>
((NULL TEM) NIL) ;LOCAL VAR WITHOUT HOME ON PDL
((NOT (DVP4 (CAAR TEM) (CDR TEM))) ;OR ELSE LOCVAR WITH DVP HOME
(CDR TEM)))) ;HOME = NON-NIL =>
;CAN STORE INTO OLD HOMELOC
(SETQ CNT (1+ CNT))
(COND ((AND (OR EFFS NLP) (NOT HOME) (OR MODE (REGADP LARG)))
(COND ((AND LARGSLOTP (NOT DOD))
(COND ((AND MODE (REGADP LARG))
(OPUSH LARG (LIST (CAR Y)) MODE))
((CONT LARG (LIST (CAR Y))))))
(T (OPUSH LARG (LIST (CAR Y)) MODE)))
(GO COMPS3)))
(COND ((AND HOME (OR (EQUAL (CADR Y) ''NIL)
(AND MODE (Q0P (CADR Y)))))
(ASIDE-FROM-FOO 'SETZM NLP HOME V MODE)
(GO COMPS3)))
(COND ((COND ((NOT DOD) NIL)
((NOT (NUMBERP LARG)) NIL)
(MODE #(NUMACP LARG))
(T #(REGACP LARG)))
(CPUSH LARG))
((AND (NULL MODE) (NUMBERP LARG) #(NUMACP LARG))
(AND DOD (CPUSH LARG))
#(PUSH (SETQ CMPVL (CONS (CAR CMPVL) CNT)) LDLST)
(MAKEPDLNUM CMPVL
(SETQ LARG (COND ((AND (NOT EFFS)
(NULL NLP)
(NOT #(NUMACP ARGNO)))
ARGNO)
((FRAC1))))))
((OR (NOT LARGSLOTP)
DOD
(MINUSP LARG)
(DVP LARG)
(AND MODE (REGADP LARG)))
(LOADAC CMPVL (SETQ LARG (COND ((AND (NOT EFFS) (NULL NLP))
(COND ((NOT #(NUMACP ARGNO))
(COND (MODE #(NUMVALAC)) (ARGNO)))
(MODE ARGNO)
((FRAC5))))
(MODE (FREENUMAC))
((FRAC5))))
NIL)))
(CONT LARG (LIST (CAR Y)))
(COND (SPFL
(SETQ Z (LIST 'SPECIAL (CAR Y)))
(COND ((ZEROP LARG) (OPOP Z NIL))
((NOT (REGADP LARG))
(BARF (LIST V LARG) |SPECIAL SET FROM ? - COMSETQ|))
(T #(OUTFS 'MOVEM LARG Z)))))
COMPS3
(COND (NLP (SETQ Y NLP) (GO COMSQ1))
((NULL EFFS)
(SETQ V (CONS (CAR Y) CNT))
(AND SPFL (SETQ SPLDLST (CONS V SPLDLST)))
(RETURN V)))))
;;; PUTS OUT THINGS LIKE (SETZ 0 (SPECIAL FOO)) (SETZB 7 -3 FXP)
;;; (AOS 0 11) (SOS 7 0 FXP)
(DEFUN ASIDE-FROM-FOO (INST NLP HOME V MODE)
((LAMBDA (AC)
(OUT1 (COND ((OR NLP EFFS) INST)
(T (SETQ AC (COND (MODE (FREENUMAC))
((NOT (DVP ARGNO)) ARGNO)
((NOT (ZEROP (SETQ AC (FRACB)))) AC)
(T (CPUSH ARGNO) ARGNO)))
(COND ((EQ INST 'SETZM) 'SETZB) (INST))))
AC
(COND ((NOT (EQ HOME T)) (CONT HOME (LIST V)) HOME)
((LIST 'SPECIAL V))))
(AND (NOT (ZEROP AC)) (CONT AC (CONS V (COND ((NOT (EQ HOME T)) 'DUP)))))
NIL)
0))
(DEFUN CSQFREEZ (V L OEFFS MODE)
((LAMBDA (OHOME HOME II N)
(SETQ V (CONS V (SETQ CNT (1+ CNT))))
(DO ZZ L (CDDR ZZ) (NULL ZZ)
(DO ((Z (SYMEVAL (CAR ZZ)) (CDR Z)) (I 0 (1+ I)) (PDLP (CADR ZZ)))
((NULL Z))
(AND (CAR Z)
(EQ (CAAR Z) (CAR V))
(COND ((MEMQ (CDAR Z) '(NIL OHOME))
(COND ((NULL PDLP) (RPLACA Z V))
((AND (NULL (CDAR Z)) (NULL HOME))
(SETQ HOME Z II (- PDLP I)))
((AND (EQ (CDAR Z) 'OHOME) (NULL OHOME))
(SETQ OHOME Z N (- PDLP I)))
((BARF NIL |KING OF CONFUSION - CSQFREEZ|))))
((MEMQ (CDAR Z) '(DUP IDUP)) (RPLACD (CAR Z) (1- CNT)))))))
(AND HOME (RPLACA HOME V))
(COND (OHOME
(COND ((DVP4 (CAR OHOME) N)
(OPUSH N
(CONS (CAR V) (GET (CAR V) 'OHOME))
MODE)
(AND HOME
(NOT OEFFS)
(EQ (GETMODE N) (GETMODE II))
(SETQ II (1- II)))))
(PUTPROP (CAR V) CNT 'OHOME))
(HOME
(COND ((DVP4 (CAR HOME) II)
(OPUSH II V MODE)
(SETQ II (1- II))))
(PUTPROP (CAR V) CNT 'OHOME)
(RPLACA HOME (CONS (CAR V) 'OHOME))))
(AND (NOT OEFFS) HOME (CONS HOME II)))
NIL NIL 0 0))
(DEFUN COMSIGNP (EXP TAG F)
((LAMBDA (Z)
(AND (NULL Z)
(SETQ Z '(- . JUMP))
(PDERR (CAR EXP) |WRONG TYPE ARG TO SIGNP|))
(LOADAC (COMP1 (CADR EXP)) 1 NIL)
(CPUSH #(NUMVALAC))
(RPLACA SLOTX NIL) ;(CONT #(NUMVALAC) NIL)
(RPLACA ACSMODE NIL) ;(SETMODE #(NUMVALAC) NIL)
(OUTPUT '(CALL 1 'NUMBERP))
(COND ((COND ((NULL TAG))
(F (CLEARVARS) (RSTD TAG 1 0) T))
(OUTPUT '(SKIPE 0 1)))
(T (CLEARVARS) (OUTJ0 'JUMPE 1 TAG NIL 1)))
(SETQ Z (COND ((OR F (NULL TAG)) (CDR Z))
((GET (CDR Z) 'CONV))))
(RPLACA REGACS NIL) ;(CONT 1 NIL)
(COND (TAG (OUTJ0 Z 'TT TAG T 0))
(T #(OUTFS Z 'TT '(* 2))
(OUTPUT '(MOVEI 1 'NIL)))))
(ASSQ (CAR EXP)
'((L . JUMPL) (E . JUMPE) (LE . JUMPLE)
(GE . JUMPGE) (N . JUMPN) (G . JUMPG)))))
(DEFUN COMTP (EXP INST TAG F VALUEP) ;INST IS LIKE ((TLNN . 161400) . (TLNE . 161400))
(PROG (TEM LOC FL ATOMP AC ACP)
(SETQ ATOMP (EQ (CAR EXP) 'ATOM) FL (OR ATOMP (NULL INST)))
(SETQ AC 0) ;TABLE INDEX FOR THAT TYPE DATUM
(SETQ LOC #(ILOCN (SETQ TEM (COMP (CADR EXP))))) ;INTO SOME FREE NUMAC, WHICH IS RETURNED
(REMOVE TEM) ;[EXCEPT FOR CASE OF "ATOM"]
(AND VALUEP (CPUSH ARGNO)) ;IF NO TAG, THEN FOR VALUE
(COND ((COND ((NUMBERP LOC) (SETQ TEM (GETMODE LOC))) ;IF QUANTITY IS KNOWN TO BE
((AND (NULL (CDR LOC))
(MEMQ (SETQ TEM (TYPEP (CADAR LOC)))
'(FIXNUM FLONUM)))))
(SETQ LOC (COND ((EQ (CAR EXP) 'TYPEP) TEM) ;EITHER FIXNUM OR FLONUM
((MEMQ (CAR EXP) '(ATOM NUMBERP)) T) ;THEN RETURN THAT INSTEAD
((EQ (CAR EXP) 'BIGP) NIL) ;OF COMPILING CODE FOR GETTING
((MEMQ (CAR EXP) '(FIXP FLOATP)) ;THE TYPE BITS INTO A NUMAC
#(EQUIV (EQ (CAR EXP) 'FIXP)
(EQ TEM 'FIXNUM)))))
(SETQ TEM #(EQUIV LOC F)) ;MATCH THE TYPE OF CADR[EXP]
(COND (TAG (AND TEM (PROG2 (CLEARVARS) (OJRST TAG 0)))) ;PREDICATES - BUT NOT "TYPEP"
((OUTPUT (COND ((NULL INST) (LIST 'MOVEI ARGNO (LIST 'QUOTE LOC)))
(#(EQUIV LOC F) (CADR (BOLA ARGNO)))
((CAR (CDDDDR (BOLA ARGNO))))))))
(RETURN T)))
(COND (#(ACLOCP LOC)
(CPUSH LOC)
(CONT LOC NIL)
(SETQ AC LOC ACP T)))
(COND ((NULL INST) ;THIS FOR "TYPEP"
(AND (OR EFFS #(NUMACP ARGNO)) (BARF NIL 'COMTP))
(OUT1 'SKIPN
(COND ((NULL ACP) (SETQ AC ARGNO) ARGNO)
(0))
LOC)
(OUTPUT (CADR (BOLA AC))) ;MOVEI ARGNO,'T SINCE NIL IS SYMBOL
#(OUTFS 'LSH AC -9.)
(OUTPUT (CONS 'HRRZ (CONS ARGNO (CDR (STGET AC)))))
(RETURN NIL)))
(COND ((NULL ACP) (SETQ AC (FREENUMAC)) (OUT1 'MOVE AC LOC)))
#(OUTFS 'LSH AC -9.)
(COND (TAG (CLEARVARS) (RSTD TAG AC 0)))
(COND (ATOMP
(SETQ INST (COND (#(EQUIV F TAG) 'SKIPL) ('SKIPGE)))
(OUTPUT (CONS INST (STGET AC)))
(COND (TAG (OUTJ0 'JUMPA 0 TAG T 0)) ;OJRST, BUT NO SUBSEQUENT DELETIONS
(VALUEP (BOOLOUT NIL NIL))))
(T (SETQ TEM (CDR (STGET AC)))
(COND ((NOT #(NUMACP AC))
(SETQ AC (FREENUMAC))
(RPLACA SLOTX NIL))) ;(CONT AC NIL
(OUTPUT (CONS 'MOVE (CONS AC TEM)))
(SETQ INST (COND (F (CAR INST)) ((CDR INST))))
(COND (TAG (OUTJ INST AC TAG))
(T #(OUTFS (CAR INST) AC (CDR INST))
(AND VALUEP (BOOLOUT NIL NIL)))))
)))
(DEFUN COMOP (EXP TAG F)
((LAMBDA (AC INST)
(COND (TAG (OUTJ INST AC TAG))
(T (CPUSH ARGNO) #(OUTFS (CAR INST) AC (CDR INST)))))
(LOCINNUMAC (COMPW EXP NIL (FREENUMAC)) 0)
(COND (F '(TRNN . 1)) ('(TRNE . 1)))))
(DEFUN COMZP (EXP TAG F)
((LAMBDA (Z INST LOC)
(SETQ INST (COND (TAG (CAR INST)) ((CDR INST))))
(AND (NOT F) (SETQ INST (GET INST 'CONV)))
(COND (TAG (OUTJ INST (LOCINNUMAC Z 0) TAG))
(T (SETQ LOC #(ILOCF Z))
(REMOVE Z)
(CPUSH ARGNO)
(OUT3 (ASSQ INST '((SKIPE) (SKIPG) (SKIPL) (SKIPN) (SKIPLE) (SKIPGE)))
0
LOC))))
(COMPW (CADR EXP) NIL (FREENUMAC))
(CDR (ASSQ (CAR EXP) '((ZEROP . (JUMPE . SKIPE))
(PLUSP . (JUMPG . SKIPG))
(MINUSP . (JUMPL . SKIPL)))))
NIL))
(COMMENT AUXILIARY FUNCTIONS)
(DEFUN 1FREE NIL (NOT (DVP1 REGACS 1)))
(DEFUN 1INSP (VAR)
(COND (#(NUMACP ARGNO)) ;TRIES TO FIGURE OUT IF A VARIALBE IS LOADAC-ABLE
(((LAMBDA (MODE) ;IN ONLY ONE INSTRUCTION; RETS CLPROGN IF ON NUMPDL
(COND ((NULL MODE) (OR CONDPNOB (NOT (MEMQ VAR UNSFLST))))
((NULL CONDPNOB) NIL)
((CLMEMBER VAR NIL #(PDLGET MODE) 'EQ) CLPROGN)))
(VARMODE VAR)))))
(DEFUN ACSMRGL (X) (ACMRG REGACS NUMACS ACSMODE (CAR X) (CADR X) (CADDR X) NIL))
(DEFUN ACMRG (LL ZZ MM L Z M F)
; MERGE ACCS OFF L ONTO LL IF F = NIL,
; SET LL FROM L IF F = T
(DO ((LL LL (CDR LL))
(L L (CDR L))
(N #(NACS) (SUB1 N)))
((ZEROP N))
(COND (F (RPLACA LL (CAR L)))
((NULL (CAR LL)))
((NOT (EQUAL (CAR LL) (CAR L))) (RPLACA LL NIL))))
(DO ((A1 MM (CDR A1))
(A2 M (CDR A2))
(N #(NUMNACS) (SUB1 N))
(LL ZZ (CDR LL))
(L Z (CDR L)))
((ZEROP N))
(COND (F (RPLACA LL (CAR L)) (RPLACA A1 (CAR A2)))
((NULL (CAR LL)))
((NOT (EQUAL (CAR LL) (CAR L)))
(RPLACA LL NIL)
(RPLACA A1 NIL)))))
(DEFUN ADD (X Y) (COND ((MEMQ X Y) Y) (T (CONS X Y))))
(DEFUN ADR (X)
(CDR (COND ((NULL X) '(NIL . NIL))
((ASSQ X GL))
(T '(NIL . NIL)))))
(DEFUN ASQSLT (X) (OR (ASSQ X REGACS) (ASSQ X REGPDL) (ASSQ X NUMACS)
(ASSQ X FXPDL) (ASSQ X FLPDL)))
(DEFUN ASSOCR (X Y)
(DO Y Y (CDR Y) (NULL Y) (COND ((EQ X (CDAR Y)) (RETURN Y)))))
(DEFUN ARRAYACCESS (X Y STORE MODE FORM)
(PROG (LOC ADDR ACX SVSLT FLAG TAKENAC1 ACLQ PARITY II)
(DECLARE (FIXNUM PARITY))
(SETQ TAKENAC1 0 PARITY 0)
(SETQ LOC (COND ((AND (NOT EFFS) (NOT #(NUMACP ARGNO))) ARGNO)
(STORE (FRAC1))
((FRAC5))))
(COND ((AND (NULL MODE) STORE)
(SETQ ADDR #(ILOCREG STORE LOC))
(REMOVS STORE)
(SETQ STORE (P2NUMCONS STORE ADDR))
#(PUSH STORE LDLST)))
(SETQ ADDR
(CONS '@
(COND ((NULL FORM) ;FORM=NIL => "ARRAYCALL" TYPE
(SETQ ACLQ (LIST (GENSYM))
ACX (COND ((OR MODE (NOT STORE))
(LOCINAC X LOC NIL (ILOCMODE X LOC NIL)))
((LOCINAC X NIL NIL NIL)))
SVSLT (FIND ACX))
(RPLACA SVSLT ACLQ)
#(PUSH ACLQ LDLST)
(LIST 1 ACX))
(T (SETQ FORM (COND ((EQ FORM T) NIL)
((CDR FORM))))
(LIST (LIST 'ARRAY X))))))
(COND ((NULL (CDR Y))
(COND ((AND STORE
MODE
(NOT (EQ (CAR STORE) 'QUOTE))
(SETQ FLAG (ILOC2 (VARBP (CAR STORE)) STORE MODE))
(NUMBERP FLAG)
(= FLAG #(NUMVALAC))
(NOT (ZEROP (FREENUMAC1))))
(SETQ TAKENAC1 #(NUMVALAC)
FLAG (LOCINNUMAC (CAR Y) 0)
TAKENAC1 0)
(OUT1 'EXCH FLAG #(NUMVALAC))
(CONT FLAG (CAR NUMACS))
(SETMODE FLAG (CAR ACSMODE))
(RPLACA NUMACS (SETQ FLAG NIL))) ;(CONT #(NUMVALAC) NIL)
((QNP (CAR Y)) (REMOVE (CAR Y)) (SETQ FLAG (CADAR Y)))
(T (LOADAC (CAR Y) #(NUMVALAC) (SETQ FLAG NIL)))))
(T (PROG (N D)
(SETQ N 0 TAKENAC1 #(NUMVALAC))
(COND ((AND FORM
(DO ((ZZ FORM (CDR ZZ)) (Z Y (CDR Z)))
((NULL Z) (SETQ FLAG T))
(COND ((AND (QNP (CAR Z))
(FIXP (SETQ ACX (CADAR Z)))
(COND ((FIXP (SETQ D (CAR ZZ))))
((EQ Y Z) (SETQ D 0) T)))
(SETQ N (+ (* D N) ACX))) ;DIMENSIONALITY AND PARTICULAR INDEX
((EQ Y Z) (RETURN NIL)) ;COMBINED WHEN BOTH ARE CONSTANT
(T (MAPC 'REMOVE (LSUB Y Z))
(COND ((FIXP (CAR ZZ))
(SETQ N (* N (CAR ZZ))
FORM (CONS NIL (CONS CLPROGN (CDR ZZ)))
Y (CONS NIL Z)))
(T (SETQ Y (CONS (LIST 'QUOTE N) Z)
FORM (CONS NIL ZZ))))
(SETQ FLAG NIL)
(RETURN T)))))
(SETQ PARITY (COND ((ODDP N) -1) (1)))
(COND (FLAG (MAPC 'REMOVE Y) ;HERE, FLAG=T SIGNALS
(SETQ FLAG N) ;A CONSTANT LINEARIZED INDEX
(RETURN NIL))
((AND (NULL (CAR Y)) (NULL (CDDR Y)))
(SETQ PARITY 0) ;PARITY HAS BEEN LOST HERE
(LOADAC (CADR Y) #(NUMVALAC) NIL)
(AND (NOT (ZEROP N)) ;NOTE THAT FLAG = NIL
#(OUTFS 'ADDI #(NUMVALAC) N))
(RETURN NIL))
(T (CPUSH #(NUMVALAC))
(SETQ TAKENAC1 (SETQ ACX (FREENUMAC)))
#(OUTFS 'MOVEI ACX N))))
(T (SETQ FLAG T)))
(SETQ N (1- (LENGTH Y)))
;AT THIS POINT, FLAG=NIL SIGNALS A PARTIAL INDEX CALCUALTION HAS BEEN DONE
(COND ((NULL FLAG))
(T (SETQ ACX (LOCINNUMAC (CAR Y) 0))
(AND (NOT (= ACX #(NUMVALAC))) (CPUSH #(NUMVALAC)))
(CONT ACX NIL)
(SETQ TAKENAC1 ACX)))
A (COND ((AND FORM (SETQ FORM (CDR FORM)) (FIXP (CAR FORM)))
(SETQ II (CAR FORM))
(AND (NOT MODE) (NOT (ODDP II)) (SETQ PARITY 1))
(COND (#(/2↑N-P II) #(OUTFS 'ASH ACX (1- (HAULONG II))))
(T (OUT2 '(IMUL) ACX (LIST (LIST 'QUOTE (CAR FORM)))))))
((OR (NULL FORM) (NOT (EQ (CAR FORM) CLPROGN)))
(AND (NOT MODE) (MINUSP PARITY) (SETQ PARITY 0))
(COND ((= ACX #(NUMVALAC))
(SETQ ACX (FREENUMAC))
(RPLACA SLOTX NIL) ;FREENUMAC LEAVES SLOTX AT AC SLOT
#(OUTFS 'MOVEI ACX 0 #(NUMVALAC))
(SETQ TAKENAC1 ACX)))
(OUTPUT (CADDDR (BOLA N))) ;"(MOVNI 7 N)"
(RPLACA NUMACS NIL) ;(CONT #(NUMVALAC) NIL)
(AND ACLQ (NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ NIL)
SVSLT (FIND (CADDR ADDR))))
(OUTPUT (CONS 'IMUL (CONS ACX ADDR)))))
(COND ((CDR (SETQ Y (CDR Y)))
(COND (MODE)
((QNP (CAR Y))
(AND (ODDP (SETQ II (CADAR Y))) (SETQ PARITY (- PARITY))))
(T (SETQ PARITY 0)))
(AAADD (CAR Y) ACX) ;"(ADD ACX LOC[(CAR Y)])"
(SETQ N (1- N))
(GO A))
(T (COND ((QNP (CAR Y))
(AND (NOT MODE) (ODDP (SETQ II (CADAR Y))) (SETQ PARITY (- PARITY)))
(REMOVE (CAR Y))
#(OUTFS 'MOVEI #(NUMVALAC) (CADAR Y) ACX))
((PROG2 (SETQ PARITY 0) (= ACX #(NUMVALAC))) (AAADD (CAR Y) ACX))
(T (LOADAC (CAR Y) #(NUMVALAC) NIL)
#(OUTFS 'ADD #(NUMVALAC) ACX)))
(CONT ACX NIL)
(RETURN (SETQ FLAG NIL))))) ;NORMAL EXIT LEAVES FLAG = NIL
(SETQ TAKENAC1 0)))
(COND (FLAG (COND ((AND MODE STORE
(NUMBERP (SETQ LOC (ILOC0 STORE MODE)))
(= LOC 7))
(SETQ LOC ((LAMBDA (TAKENAC1) (FREENUMAC)) #(NUMVALAC)))
(LOADAC STORE LOC NIL))
(T (CPUSH #(NUMVALAC))))) ;NON-NULL FLAG INDICATES CONSTANT
(T #(PUSH (SETQ FORM (LIST (GENSYM))) LDLST) ;INDEX NOT YET LOADED; NULL FLAG
(RPLACA NUMACS FORM) ;MEANS COMPUTED INDEX IN NUMVALAC
(RPLACA ACSMODE 'FIXNUM)))
(AND MODE (GO NUMARRAY))
SARRAY
(SETQ ACX T) ;FLAG ON WHETHER OR NOT TO LOOK UP ACLQ AGAIN
(SETQ LOC (COND (STORE (LOCINAC STORE NIL NIL (ILOC0 STORE NIL)))
((AND (NOT EFFS) (NOT #(NUMACP ARGNO)))
(SETQ ACX NIL)
(AND ACLQ (REMOVE ACLQ))
(CPUSH ARGNO)
ARGNO)
(T (FRAC5))))
(AND ACLQ ACX (NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ LOC)
SVSLT (FIND (CADDR ADDR))))
(SETQ ADDR (CONS LOC ADDR))
(COND (FLAG #(OUTFS 'MOVEI #(NUMVALAC) (LSH FLAG -1))
(OUTPUT (CONS (COND ((ODDP (SETQ II FLAG)) (COND (STORE 'HRRM) ('HRRZ)))
(T (COND (STORE 'HRLM) ('HLRZ))))
ADDR)))
(T (REMOVE FORM)
(COND ((ZEROP PARITY)
(OUTPUT ##(SUBST (NUMVALAC) 'AC ''(ROT AC -1)))
(OUTPUT ##(SUBST (NUMVALAC) 'AC ''(JUMPL AC (* 3))))
(OUTPUT (CONS (COND (STORE 'HRLM) ('HLRZ)) ADDR))
(OUTPUT '(JUMPA 0 (* 2)))
(OUTPUT (CONS (COND (STORE 'HRRM) ('HRRZ)) ADDR))
(OUTPUT 'FOO))
(T (COND ((OR ATPL ATPL1
(NOT (EQ (CAR LOUT) 'MOVEI))
(COND ((EQ (CAR LOUT1) 'ASH) NIL)
((EQ (CAR LOUT1) 'IMULI) (ODDP (CADDR LOUT1))))
(NOT (= (CADDDR LOUT) (CADR LOUT1))))
(OUTPUT ##(SUBST (NUMVALAC) 'AC ''(ROT AC -1))))
(T (RPLACA (CDDR LOUT1)
(COND ((EQ (CAR LOUT1) 'ASH) (1- (CADDR LOUT1)))
(T (// (CADDR LOUT1) 2))))
(RPLACA (CDDR LOUT) (// (CADDR LOUT) 2))))
(OUTPUT (COND ((PLUSP PARITY) (CONS (COND (STORE 'HRLM) ('HLRZ)) ADDR))
((CONS (COND (STORE 'HRRM) ('HRRZ)) ADDR))))))))
(GO END)
NUMARRAY
(COND (FLAG #(OUTFS 'MOVEI #(NUMVALAC) FLAG) (RPLACA NUMACS NIL))) ;(CONT #(NUMVALAC) NIL)
(SETQ LOC (COND (STORE ((LAMBDA (TAKENAC1) (LOCINNUMAC STORE 0)) #(NUMVALAC)))
(T (COND (#(NUMACP ARGNO) ARGNO) (#(NUMVALAC))))))
(AND ACLQ (NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ NIL)
SVSLT (FIND (CADDR ADDR))))
(OUTPUT (CONS (COND (STORE 'MOVEM) ('MOVE)) (CONS LOC ADDR)))
(SETMODE LOC MODE)
(AND (NULL FLAG) (REMOVE FORM))
END
(COND (ACLQ (RPLACA SVSLT NIL) (REMOVE ACLQ)))
(RETURN LOC)))
(DEFUN ACLQ-FIND (ACLQ LOC)
((LAMBDA (ACX)
(COND ((AND (NUMBERP ACX) #(REGACP ACX)))
((NULL LOC) (LOADAC ACLQ (SETQ ACX (FRAC5)) NIL))
(((LAMBDA (SVSLT)
(SETQ LOC (CAR SVSLT))
(RPLACA SVSLT '(NIL . TAKEN))
(LOADAC ACLQ (SETQ ACX (FRAC5)) NIL)
(RPLACA SVSLT LOC))
(FIND LOC))))
(LIST '@ 1 ACX))
(ILOC0 ACLQ NIL)))
(DEFUN AAADD (ITEM ACX) ;ARRAYACCESS "ADD"
(OUT3 '(ADD) ACX (ILOCMODE ITEM 'FREENUMAC 'FIXNUM))
(REMOVE ITEM))
(DEFUN 6BSTR (X)
(AND (NOT #(SYMBOLP X)) (SETQ X (MAKNAM (EXPLODEN X))))
(DO ((I 1 (1+ I)) (N 0) (ZZ NIL (CONS N ZZ)))
((ZEROP (SETQ N (GETCHARN X I))) (MAKNAM (NRECONC ZZ '(/!))))
(COND ((OR (= N 43) (= N 136) (= N 41)) (SETQ ZZ (CONS '/# ZZ))) ;CHECK FOR # ↑ !
((LESSP 37 N 140)) ;VALID SIXBIT
(T (SETQ ZZ (CONS '/↑ ZZ)) ;ELSE CONTROLIFY
(AND (= N 15) (= (GETCHARN X (1+ I)) 12) (SETQ I (1+ I)))
(SETQ N (BOOLE 6 N 100))))))
(DEFUN BADTAGP (TAG)
((LAMBDA (TEM)
(AND (OR (NOT (EQ (L/.LE/. REGPDL (CAR TEM)) 'EQUAL))
(NOT (EQ (L/.LE/. FXPDL (CADR TEM)) 'EQUAL))
(NOT (EQ (L/.LE/. FLPDL (CADDR TEM)) 'EQUAL)))
(LEVELTAG)))
(CDDDR (LEVEL TAG))))
(DEFUN BOOL1LCK (EXP TAG F)
((LAMBDA (T1)
(COND (T1 (BOOL1 EXP T1 (NOT F))
(OJRST TAG NIL)
(SLOTLISTSET (GET T1 'LEVEL))
(OUTTAG0 T1))
(T (BOOL1 EXP TAG F))))
(BADTAGP TAG)))
(DEFUN BOOL1 (EXP TAG F)
; COMPILE GENERAL BOOLEAN FORM, JRST TO TAG WHEN RESULT
; MATCHES F, OTHERWISE DROP THROUGH
; RETURN NON NIL ONLY WHEN UNCONDITIONAL JRST TAKEN
(PROG (PROP)
(SETQ PROP (AND (ATOM (CAR EXP)) (GET (CAR EXP) 'P1BOOL1ABLE)))
(COND ((EQ PROP T)
(COND ((COND ((EQ (CAR EXP) 'AND)
(BOOL2 (CDR EXP) TAG F T)
T)
((EQ (CAR EXP) 'OR)
(BOOL2 (CDR EXP) TAG (NOT F) NIL)
T))
(SETQ CNT (PLUS CNT 2)))
((EQ (CAR EXP) 'NULL) (RETURN (BOOL1 (CADR EXP) TAG (NOT F))))
((EQ (CAR EXP) 'COND) (COMCOND (CDR EXP) TAG F NIL))
((EQ (CAR EXP) 'EQ) (COMEQ (CDR EXP) TAG F))
((MEMQ (CAR EXP) '(ZEROP PLUSP MINUSP)) (COMZP EXP TAG F))
((EQ (CAR EXP) 'MEMQ)
(AND F (RETURN (BOOL3 EXP T TAG F))) ;CLOSE-CALL, AND JUMPN
((LAMBDA (X Y LX ARGNO A1 A2 EFFS OEFFS)
(DECLARE (FIXNUM A1 A2))
(SETQ X (COMP0 (CADR EXP)) Y (COMP0 (CADDR EXP)))
(SETQ EFFS OEFFS)
(SETQ LX #(ILOCF X))
(SETQ A1 (LOCINAC Y NIL NIL NIL))
(CLEARVARS)
(CONT A1 '(NIL . TAKEN))
(CONT (SETQ A2 #(FREACB)) NIL)
(OUTJ0 'JUMPE A1 TAG NIL A2)
(AND (NOT (REGADP LX))
(DBARF EXP |NUMERIC 1ST ARG TO MEMQ?| 4 6))
(AND (NUMBERP LX)
(NOT (EQUAL X (CONTENTS LX)))
(SETQ LX (ILOC0 X NIL)))
(REMOVEB X)
(OUT1 '(HLRZ) A2 A1)
(OUT1 '(HRRZ) A1 A1)
(OUT1 'CAME A2 LX)
(OUTPUT '(JUMPA 0 (* -4)))
(CONT A1 NIL)
A1)
NIL NIL NIL 1 0 0 NIL EFFS))
((EQ (CAR EXP) 'SIGNP) (COMSIGNP (CDR EXP) TAG F))
((BARF NIL |LOST DISPATCH IN BOOL1|))))
((NULL PROP)
(COND ((AND (EQ (CAR EXP) 'PROG2) (NULL (CDDDR EXP)))
(COMPE (CADR EXP))
(RST TAG)
(RETURN (BOOL1 (CADDR EXP) TAG F)))
((RETURN (BOOL3 EXP T TAG F)))))
((EQ PROP 'NUMBERP)
(COND (CLOSED (RETURN (BOOL3 EXP T TAG F)))
((AND (MEMQ (CAR EXP) '(GREATERP LESSP))
#(KNOW-ALL-TYPES (CADR EXP)))
(COMGRTLSP EXP TAG F))
((AND (EQ (CAR EXP) 'EQUAL)
(MEMQ (CADR EXP) '(FIXNUM FLONUM)))
(COMEQ (CDR EXP) TAG F))
((AND (EQ (CAR EXP) 'ODDP)
(MEMQ (CADR EXP) '(FIXNUM FLONUM)))
(COMOP (CADDR EXP) TAG F))
((RETURN (BOOL3 EXP T TAG F)))))
((NOT (ATOM PROP)) (COMTP EXP PROP TAG F NIL))
((BARF (CAR EXP) |HAS BAD P1BOOL1ABLE PROP|)))))
(DEFUN BOOL2 (EXP TAG F ANDFL)
; COMPILE AND OR
(COND (F (COND ((CDR (SETQ EXP (L2F (CDDDDR EXP))))
(BOOL2LOOP (CDR EXP) (SETQ F (LEVELTAG)) (NOT ANDFL)))
(T (SETQ F NIL)))
(BOOL1 (CAR EXP) TAG ANDFL)
(OUTTAG F))
(T (BOOL2LOOP (CDDDDR EXP) TAG (NOT ANDFL)))))
(DEFUN BOOL2LOOP (EXP BTAG B2F) (MAPC '(LAMBDA (EXP) (BOOL1 EXP BTAG B2F)) EXP))
(DEFUN BOOL3 (EXP FLAG TAG F)
(PROG (Z LARG LARGSLOTP FL MODE)
(SETQ Z (COND (FLAG (COMPR EXP NIL T T)) (EXP)))
(SETQ LARG #(ILOCF Z))
(SETQ LARGSLOTP (NUMBERP LARG))
(AND LARGSLOTP (SETQ MODE (GETMODE LARG)))
(COND ((AND (NOT LARGSLOTP) (EQ (CAAR LARG) 'QUOTE))
(REMOVE Z)
(COND (#(EQUIV (CADAR LARG) F)
(CLEARVARS)
(OJRST TAG NIL)
(RETURN T))
(T (RETURN NIL)))))
(COND ((NOT (REGADP LARG)) (REMOVE Z) (CLEARVARS)
(RETURN (COND (F (OJRST TAG NIL) T)))))
(SETQ FL (RST TAG))
(REMOVE Z)
(AND (OR (CLEARVARS) FL)
LARGSLOTP
(NOT (PLUSP LARG))
(SETQ LARG (ILOC0 Z MODE)))
(OUTJ0 (COND (F 'JUMPN) ('JUMPE)) LARG TAG NIL LARG)
(RETURN NIL)))
(DEFUN BOOLOUT (TAG FL)
(COND ((NOT (LESSP 0 ARGNO #(NUMVALAC)))
(WARN NIL |PREDICATE IN NUMERICAL ARGUMENT POSITION|)
(OUTPUT (SUBST ARGNO 'ARGNO '(MOVEI ARGNO 0))))
(((LAMBDA (TEM)
(OUTPUT (CAR TEM))
(AND TAG
(COND (FL (AND (OUTTAG TAG)
(NOT (EQ LOUT1 (CAR TEM)))
(BARF TAG |LOST IN BOOLOUT|)))
(T (OUTPUT TAG))))
(OUTPUT (CADR TEM))
(OUTPUT 'FOO))
(BOLA ARGNO)))))
(DEFUN CARCDR (ITEM ACORFUN)
; COMPUTES A CARCDR COMPILATION - RETURNS SLOTLIST NUMBER OF RESULTANT
; TYPICAL ITEM IS (G0025 (D A D D) X . 5) FOR (CDDADR X)
; IF ITEM IS (G0025 (CARCDR-FREEZE A D A D . . .) X . 5),
; THEN NO VL CROSSINGS MAY BE MADE TO LINK TO IT
(DECLARE (FIXNUM (ACORFUN NOTYPE)))
(PROG (AC T1 2LONG T2 LT2 ACP N MATCHP TEM FL)
(SETQ ACP (NUMBERP ACORFUN) N 0 T1 (CADR ITEM))
(AND (EQ (CAR T1) 'CARCDR-FREEZE) (SETQ T1 (CDR T1)))
(SETQ LT2 #(ILOCREG (SETQ T2 (CDDR ITEM))
(COND ((AND ACP #(REGACP ACORFUN)) ACORFUN)
((FRAC)))))
(REMOVE T2)
(COND ((AND (ATOM (CAR T2))
(VARBP (CAR T2))
(DO ((ZZ SPLDLST (CDR ZZ)) (2LONG-SETP)) ;LOOK FOR (GN (A . .) X.5)
((NULL ZZ) MATCHP)
(AND (CAR ZZ)
(NOT (EQ ITEM (CAR ZZ)))
(NOT (ATOM (CDAR ZZ))) ;FOUND (GM . .)
(EQ (CADDAR ZZ) (CAR T2)) ; FOUND (GM . . X.7)
(EQ (CAADAR ZZ) (CAR T1)) ;FOUND (GM (A . .) X.7)
(COND (2LONG-SETP) ;THIS COND ALWAYS RETURNS T
(ACP (SETQ 2LONG #(NUMACP ACORFUN)
2LONG-SETP T))
((SETQ 2LONG (OR (EQ ACORFUN 'FREENUMAC)
(EQ ACORFUN 'ARGNO))
2LONG-SETP T)))
(COND (2LONG (ASQSLT (CAAR ZZ))) ;2LONG IS SWITCH TO TELL
((ASSQ (CAAR ZZ) REGACS)) ;WHETHER OR NOT TO LOOK
((ASSQ (CAAR ZZ) REGPDL))) ;EVERYWHERE FOR POSSIBILITIES
(EQUAL (ILOC0 (CDDAR ZZ) NIL) LT2) ;X.5 CAN BE USED FOR X.7
(PROG (L LL)
(SETQ L T1) ;T1- OPEN STRING OF ITEM
(SETQ LL (CADAR ZZ)) ;LL - OPEN STRING OF CANDIDATE
(AND (< (LENGTH LL) N) (RETURN NIL))
A (COND ((NOT (EQ (CAR L) (CAR LL))) (RETURN NIL))
((SETQ LL (CDR LL))
(COND ((SETQ L (CDR L)) (GO A))
((RETURN NIL)))))
;CANDIDATE IS AN INITIAL SUBSTRING OF ITEM
(SETQ MATCHP (CAR ZZ) N (LENGTH (CADR MATCHP)))))))
(COND ((EQUAL (CADR MATCHP) T1)
#(PUSH (CONS (CAR MATCHP) (CAR ITEM)) VL)
(RETURN (ILOCMODE MATCHP NIL '(FIXNUM FLONUM))))
(T (SETQ T2 (LIST (GENSYM))
T1 (NCDR T1 N)
LT2 (ILOCMODE MATCHP NIL '(FIXNUM FLONUM)))
#(PUSH (CONS (CAR MATCHP) (CAR T2)) VL)))))
(SETQ 2LONG (CDDDR T1))
(SETQ AC (COND ((NOT ACP)
(COND ((AND 2LONG (OR (EQUAL LT2 1) (1FREE)))
1)
(T ((LAMBDA (LDLST LL)
(COND (2LONG (CC0 (FRAC)))
((EQ ACORFUN 'FRACF) (FRACF))
((EQ ACORFUN 'FREENUMAC) (FREENUMAC))
((EQ ACORFUN 'ARGNO)
(COND ((AND (NOT EFFS)
(= ARGNO 1)
(PROG2 (SETQ LDLST LL)
(DVP1 REGACS 1)
(SETQ LDLST TEM)))
(CC0 (FRAC)))
((OR EFFS #(NUMACP ARGNO)) (FRACF))
(ARGNO)))
((BARF ACORFUN |? FUN - CARCDR|))))
(SETQ TEM (CONS T2 LDLST)) LDLST))))
((OR (NOT 2LONG) (= ACORFUN 1)) ACORFUN)
((OR (EQUAL LT2 1) (1FREE)) 1)
((AND (CDDR 2LONG) (NOT (ZEROP (SETQ N (FRAC))))) (CC0 N))
(T ACORFUN)))
(SETQ TEM (COND ((AND #(PDLLOCP LT2) (NOT #(NUMACP AC)))
;LT2 MUST ALWAYS BE A REGADP. THUS IF IT IS A PLDLOCP, IT IS THE REGPDL
; AND IF AC IS A REGAC, THE A CPUSH MIGHT CHANGE THE REGPDL
(SETQ FL T)
(AND (NULL TEM) (SETQ TEM (CONS T2 LDLST)))
((LAMBDA (LDLST) (CPUSH AC)) TEM)) ;ORDINARYIL, A SEMIPUSH WOULD BE NEEDED
(T (SETQ FL NIL) (CPUSH AC)))) ;BUT THE LDLST PREVENTS TROUBLE HERE
; LOSING T2 MAY HAVE MOVED AROUND BY CC0 OR CPUSH
(COND ((OR (NOT ACP) (AND TEM FL))
(SETQ LT2 (ILOC0 T2 NIL))))
(SETQ FL NIL ACP #(ACLOCP LT2) MATCHP NIL)
B (COND ((AND ACP (= LT2 1) (= AC 1) (CDDR T1))
;ACP NOW APPLIES TO LT2, WHICH IS PLACE TO START [OR CONTINUE] CARCDRING FROM
;T1 CONTAINS D-A LIST OF DIRECTIONS, AND THIS CLAUSE IS TAKEN IF 3 OR MORE.
;FL=T => WE HAVE A PRIVATE COPY OF CURRENT PORTION OF T1
(AND (NULL FL) (SETQ FL (SETQ T1 (APPEND T1 NIL))))
(COND ((CDDDDR T1)
(AND (NOT MATCHP) (SETQ MATCHP T) (CLEARNUMACS))
;IF MORE THAN 4, THEN BITE OF A CHUNK OF 4, FEED TO CCOUT, AND CARRY ON
(CCOUT (PROG2 NIL T1 (RPLACD (SETQ T1 (CDDDR T1)) (PROG2 #(POP T1) NIL))))
(GO B))
((CCOUT T1))))
(T (AND (AND (NOT ATPL) (NOT ATPL1))
(EQ (CAR LOUT) 'MOVE) ;IF LOUT = (MOVE AC 0 AC)
(MEMQ (CAR LOUT1) '(HRRZ HLRZ))
(NUMBERP (CADR LOUT))
(SIGNP E (CADDR LOUT)) ;AND LOUT1 HAD JUST LOADED AC
(NUMBERP (CADDDR LOUT))
(= (CADR LOUT) AC) ;THEN FLUSH LOUT
(= (CADDDR LOUT) AC)
(EQUAL (CADR LOUT1) AC)
(SETQ LOUT (SETQ ATPL 'FOO)))
(OUT1 (GET (CAR T1) 'INST) AC LT2)
(COND (#(POP T1) (SETQ LT2 AC ACP T) (GO B)))))
(CONT (SETQ N AC) (LIST (CAR ITEM)))
(COND ((COND (#(NUMACP AC))
((EQ ACORFUN 'FREENUMAC)
(SETQ TEM (CAR SLOTX) AC (FREENUMAC))
(RPLACA SLOTX TEM) ;QUICK WAY OF (CONT N (CONTENTS AC))
T))
(SETMODE AC NIL)
(OUT1 '(MOVE) AC N)))
(RETURN AC) ))
(DEFUN CCOUT (X) ;(D A D D) => (CALL 1 'CDDADR)
((LAMBDA (FUN)
#(OUTFS 'JSP
'T
(LIST 'CARCDR (CDDR (GET FUN 'CARCDR)))
0
FUN))
(IMPLODE (CONS 'C (NRECONC X '(R))))))
(DEFUN CC0 (AC)
; SHOULD BE CALLED ONLY WHEN (DVP (CONTENTS 1)) ALSO, (FRAC) LEAVES SLOTX SET
(COND ((ZEROP AC) (CPUSH1 1 NIL NIL))
((= AC 1))
((CCSWITCH AC 1)) ;IF CCSWITCH IS NIL, THE SLOTX IS UNDISTURBED
(T (RPLACA SLOTX (CAR REGACS)) ;(CONT AC (CONTENTS 1))
(RPLACA REGACS ;(CONT 1 (CONS (CAAR (CONTENTS 1)) 'DUP))
(CONS (CAAR REGACS) 'DUP))))
1)
(DEFUN CCSWITCH (A1 A2) ;A1 IS ALWAYS A REGAC ADDRESS
(COND ((AND (NOT ATPL)
(MEMQ (CAR LOUT) '(MOVE HRRZ HLRZ MOVEI))
(NUMBERP A2)
(NUMBERP (CADR LOUT))
(= (CADR LOUT) A2))
(OUTPUT (PROG2 NIL
(CONS (CAR LOUT) (CONS A1 (CDDR LOUT)))
(SETQ LOUT (SETQ ATPL 'FOO))))
(SETQ A1 (FIND A1) A2 (FIND A2)) ;THIS MIGHT MOVE CARCDRS ITEM
(RPLACA A1 (CAR A2)) ;(CONT A1 (CONTENTS A2))
(RPLACA A2 NIL) ;(CONT A2 NIL)
T)
(T (OUT1 'MOVE A1 A2)
NIL)))
(DEFUN CARCDR-FREEZE (V ITEM)
((LAMBDA (FL)
(MAP '(LAMBDA (LL)
(COND ((NULL (CAR LL)) (SETQ FL NIL))
((OR (ATOM (CDAR LL)) (NOT (EQ (CADDAR LL) V))))
((OR (ASSQ (CAAR LL) LDLST) (DVP3 (CAAR LL) VL) (AND ITEM (EQ (CAAR LL) ITEM)))
(AND (NOT (EQ (CAADAR LL) 'CARCDR-FREEZE)) ;MODIFY THE SPLDLST SO THAT
(RPLACA LL (CONS (CAAR LL) ;NO VL CROSSINGS CAN USE THIS
(CONS (CONS 'CARCDR-FREEZE (CADAR LL))
(CDDAR LL))))))
(T (CLOBBER-SLOT (CAR LL) REGACS)
(CLOBBER-SLOT (CAR LL) REGPDL)
(RPLACA LL (SETQ FL NIL))))) ;REMOVE THIS LOSER FROM SPLDLST
SPLDLST)
(AND (NULL FL) (FLUSH-SPL-NILS)))
T))
(DEFUN CLOBBER-SLOT (X L) (AND (SETQ X (ASSQ (CAR X) L)) (RPLACA (MEMQ X L) NIL)) NIL)
(DEFUN CLEANUPSPL (CLBFL)
;;; CLEAN UP THE SPLDLST BY TOSS ING OUT WORTHLESS STUFF
;;; CLBFL=NIL ALLOWS CARCDRINGS STILL IN THE SLOTLIST TO STAY AROUND
;;; FOR POSSIBLE FUTURE VL CROSSINGS
(PROG (FL)
(SETQ FL T)
(MAP '(LAMBDA (LL)
(AND (NOT (COND ((ATOM (CDAR LL)) (CLMEMBER (CAAR LL) (CDAR LL) LDLST '=))
((ASSQ (CAAR LL) LDLST))
((NOT CLBFL) (ASQSLT (CAAR LL)))))
(RPLACA LL (SETQ FL NIL))))
SPLDLST)
(AND (NULL FL) (FLUSH-SPL-NILS))))
(DEFUN CLMEMBER (X Y L FUN)
;;; A QUICK WAY OF DOING (MEMBER ZZ L) WHERE X = (CAR ZZ) Y = (CDR ZZ)
;;; AND THE EXPECTATION IS THAT THE "MEMBER" WILL USUALLY FAIL
(DO Z L (CDR Z) (NULL Z)
(AND (CAR Z)
(EQ X (CAAR Z))
(COND ((EQ FUN 'EQ) (EQ Y (CDAR Z)))
((EQ FUN '=) (AND (NUMBERP (CDAR Z)) (= (CDAR Z) Y)))
((EQ FUN 'EQUAL) (EQUAL Y (CDAR Z))))
(RETURN Z))))
(DEFUN CLLOC (Z MODE) (CONVNUMLOC (- (LENGTH Z) (LENGTH #(PDLGET MODE))) MODE))
(DEFUN CLCHK (PDL L) (AND PDL (CAR PDL) (NULL (CDAR PDL)) (ASSQ (CAAR PDL) L)))
(DEFUN CLEAR (Y CLBFL)
; CLEAR UP THE STATUS OF THINGS THAT MIGHT GET CLOBBEED IN A COND, PROG, LAMBDA [OR LSUBR APLICATION]
; PROGN ON Y ==> UNKNOWN-FUNTION-APPLICATION IN FORM
; NULFU ON Y ==> RPLACA-D IN FORM
; GOFOO ON Y ==> GO OR RETURN IN FORM
; VARIABLE X ==> (SETQ X FOO) IN FORM
(AND Y
(PROG (L MODE Z PDL)
(SETQ L (MAPCAN
'(LAMBDA (X)
(COND ((OR (EQ X GOFOO) (EQ X NULFU) (EQ X PROGN) #(SPECIALP X))
NIL)
(T
(SETQ MODE (VARMODE X) PDL #(PDLGET MODE))
(COND ((AND MODE
(COND ((SETQ L (CLMEMBER X NIL REGPDL 'EQ))
(SETQ Z (- (LENGTH L) (LENGTH REGPDL)))
T)
((SETQ L (CLMEMBER X NIL REGACS 'EQ))
(SETQ Z (- (1+ #(NACS)) (LENGTH L)))
T)))
; DONT LET LOCAL NUMVARS BE HOMED IN THE REGWORLD
(OPUSH Z (CAR L) MODE)
(RPLACA L (CONS X CNT))
(SETQ L PDL))
(T (SETQ L (CLMEMBER X NIL PDL 'EQ))))
(COND ((OR (NULL L) (NULL (SETQ PDL (CLMEMBER X 'OHOME PDL 'EQ))))
NIL)
(T (LIST (LIST X MODE L PDL)))))))
Y))
; L IS A LIST OF LOSER THAT HAVE BOTH VALID HOMES AND OHOMES ON THE PDL
A (COND ((NULL L) (GO C))
((OR (SETQ Z (CLCHK (SETQ PDL REGPDL) L))
(SETQ Z (CLCHK (SETQ PDL FXPDL) L))
(SETQ Z (CLCHK (SETQ PDL FLPDL) L)))
(SETQ L (DELQ Z L) MODE (CADR Z))
(RPLACA (CADDDR Z) (CAR PDL))
(OPOP (CLLOC (CADDDR Z) MODE) MODE)
(GO A)))
B (COND ((SETQ MODE (CADAR L)) (SETQ Z (FREENUMAC)))
(T (SETQ Z (FRAC5)))) ;SLOTX LEFT SET BY FREAC
(SETQ PDL (CADDAR L))
(OUT1 'MOVE Z (CLLOC PDL MODE))
(RPLACA SLOTX (CAR PDL))
(RPLACA PDL NIL)
(CPUSH1 Z NIL NIL) ;SLOTX STILL SET
(GO A)
C (COND ((MEMQ GOFOO Y) (SETQ CLBFL T) (CPVRL)) ;MAKE SURE RELEVANT PROG
((AND PVRL (NULL LPRSL)) (CNPUSH (LAND PVRL Y) NIL))) ;VARS HAVE A HOME
; DITTO FOR LAMBDA VARIALBES
(AND OLVRL (CNPUSH (LAND OLVRL Y) NIL))
; PUSH OUT DELAYED SPECIALS OR CARCDRS THAT MIGHT BE CLOBBERED
(AND LDLST
(COND ((MEMQ PROGN Y) (CSLD T T Y))
(T (CSLD NIL (MEMQ NULFU Y) Y)))))) ;DEPENDING ON INPUT, WE FLUSH OUT THE ACS
(AND CLBFL (CLEARACS0 NIL)))
(DEFUN CLEARACS (N CLBFL HOME)
(DECLARE (FIXNUM MODEFL))
(PROG (I FL MODEFL)
A (COND ((MINUSP N)
(SETQ SLOTX NUMACS) (SETQ I #(NUMVALAC))
(SETQ MODEFL (SETQ N (- #(NUMVALAC) 1 N))))
((SETQ SLOTX REGACS) (SETQ I 1) (SETQ MODEFL 0)))
B (COND ((EQ (CPUSH1 I HOME NIL) 'PUSH) (SETQ FL T)))
(AND CLBFL (RPLACA SLOTX NIL))
(COND ((GREATERP (SETQ I (ADD1 I)) N)
(AND (NOT (ZEROP MODEFL)) CLBFL (CLEARACSMODE MODEFL)) (RETURN FL))
((NULL #(POP SLOTX))
(SETQ N (DIFFERENCE #(NACS) N))
(GO A))
((GO B)))))
(DEFUN CLEARACS0 (CLBFL) (CLEARACS ##(+ (NACS) (NUMNACS)) CLBFL NIL))
(DEFUN CLEARACS1 (X HOME)
(CLEARACS (COND ((AND X (GET X 'ACS))) (#(NACS))) T HOME)
(CLEARACS ##(- (NUMNACS)) T HOME))
(DEFUN CLEARVARS NIL (CLEARACS ##(+ (NACS) (NUMNACS)) NIL 'CLEARVARS))
(DEFUN CLEARNUMACS NIL (CLEARACS ##(- (NUMNACS)) T NIL))
(DEFUN CLEARACSMODE (N)
(RPLACA ACSMODE NIL)
(COND ((> N #(NUMVALAC))
(RPLACA (CDR ACSMODE) NIL)
(COND ((> N ##(1+ (NUMVALAC)))
(RPLACA (CDDR ACSMODE) NIL))))))
(DEFUN CONVNUMLOC (AC MODE)
(COND ((NULL MODE) AC)
(#(ACLOCP AC) (+ AC ##(1- (NUMVALAC))))
((EQ MODE 'FIXNUM) (- AC 5000))
((- AC 10000))))
(DEFUN CONT (N Y) (RPLACA (FIND N) Y))
(DEFUN CONTENTS (N) (CAR (FIND N)))
(DEFUN CPUSH (N) (FIND N) (CPUSH1 N NIL NIL))
;;; IF SLOTX = (FIND N) , THEN CPUSH1 WILL COMPILE A PUSH (OR MOVE) TO THE PDL FROM N
;;; MUST PRESERVE SLOTX
(DEFUN CPUSH1 (N HOME DONT)
(COND ((OR (NULL (CAR SLOTX))
(EQ (CAAR SLOTX) 'QUOTE)
(EQ (CDAR SLOTX) 'DUP))
NIL)
((EQ (CDAR SLOTX) 'TAKEN) (AND (NOT (EQ HOME 'CLEARVARS)) (CPUSH2 (GETMODE N) N)))
(((LAMBDA (VFL)
(COND ((NOT (DVP2 (CAR SLOTX) N VFL)) NIL) ;IF NOT DVP, THEN RETURN NIL
((NOT VFL) ;FOR GENSYM STUFF, PUSH ONLY
(AND (NOT (EQ HOME 'CLEARVARS)) ;IF NOT RESTRICTED BY HOME
(CPUSH2 (GETMODE N) N)))
((EQ HOME 'GENSYM) NIL) ;VARS NOT PUSHED IF RESTRICTED
(((LAMBDA (MODE)
(COND ((CDAR SLOTX)
(OPUSH N (CAR SLOTX) MODE)
(RPLACA SLOTX NIL)
'PUSH)
((CPUSHFOO N DONT MODE) 'MOVEM) ;TAKE EXISTING HOME-SLOT ON PDL
((CPUSH2 MODE N))))
(GETMODE N))))) ;OR CREATE PDL HOME FOR LOCAL VAR
(VARBP (CAAR SLOTX))))))
(DEFUN CPUSHFOO (N DONT MODE)
((LAMBDA (T1 T2 SL BESTCNT BESTLOC M)
(AND (NOT (FIXP DONT)) (SETQ DONT NIL))
(DO ((Z #(PDLGET MODE) (CDR Z))
(I 0 (1- I)))
((NULL Z))
(AND (EQ (CAAR SLOTX) (CAAR Z))
(PROG2 (SETQ T1 (CONVNUMLOC I MODE)) T)
(OR (NULL DONT) (NOT (= DONT T1)))
(COND ((AND (EQ (CDAR Z) 'OHOME)
(NOT (DVP4 (CAR Z) T1)))
(SETQ SL Z BESTLOC T1)
(RETURN NIL))
((NOT (DVP1 Z T1))))
(PROG2 (SETQ T2 (COND ((NUMBERP (CDAR Z)) (CDAR Z)) (CNT)))
(> T2 BESTCNT))
(SETQ SL Z BESTLOC T1 BESTCNT T2)))
(COND (SL (SETQ M (LENGTH #(PDLGET MODE)))
(AND (REGADP N)
(NOT (REGADP BESTLOC))
(SETQ SLOTX
(PROG2 NIL
SLOTX
(SETQ N (LOCINNUMAC (CONS (CAR (CONTENTS N)) CNT) 0)))))
(SETQ BESTLOC (+ BESTLOC
(COND ((MINUSP (SETQ M (- M (LENGTH #(PDLGET MODE))))) 1)
((PLUSP M) -1)
(0))))
(COND ((AND (= N 1)
(= BESTLOC 0)
(NULL MODE)
(AND (NOT ATPL) (NOT ATPL1))
(MEMQ (CAR LOUT) '(CALL CALLF))
(EQUAL LOUT1 '(PUSH P 1)))
(SETQ LOUT1 (SETQ ATPL1 'FOO))
(OUTPUT '(PUSH P 1)))
(T (OUT1 'MOVEM N BESTLOC)))
(RPLACA SL (PROG2 NIL (CAR SLOTX) (RPLACA SLOTX (CONS (CAAR SLOTX) 'DUP))))
T)))
0 0 NIL 0 0 0))
(DEFUN CPUSH2 (MODE N)
(OPUSH N (CAR SLOTX) MODE)
(RPLACA SLOTX (CONS (CAAR SLOTX) 'DUP))
'PUSH)
(DEFUN CSLD (VFL CCFL Y)
((LAMBDA (L TEM T2 SVSLT SLOTLOC)
(DO Z LDLST (CDR Z) (OR (NULL Z) (EQ Z EXLDL))
A (COND ((NULL (CDAR Z)) ; ITEM IS LIKE (G00001)
(AND CCFL
(SETQ TEM (ASSQ (CAAR Z) SPLDLST))
(NOT (ASQSLT (CAAR Z)))
#(PUSH TEM L)))
;;; ### DOES A "MEMQ" REALLY WORK HERE? IS "MEMBER" OR "CLMEMBER" NECESSARY
((AND (OR (AND VFL (MEMQ (CAR Z) SPLDLST)) ;LOADING UP SPECIAL VARS
(MEMQ (CAAR Z) Y)) ;LOADING SETQ VARS
(COND (#(PDLLOCP (SETQ TEM (ILOC2 T (CAR Z) (VARMODE (CAAR Z)))))
(SETQ T2 NIL)
(NULL (CDR (CONTENTS TEM))))
((AND (SETQ T2 #(ACLOCP TEM)) (EQ (CDR (CONTENTS TEM)) 'DUP))
(SETQ SVSLT (CAR (SETQ SLOTLOC (FIND TEM))))
(RPLACA SLOTLOC NIL)
(GO A))
(T)))
(AND T2 ;T2 HAS REMEMBERED #(ACLOCP TEM)
(NOT #(SPECIALP (CAAR Z)))
(NULL (CDR (CONTENTS TEM)))
(CPUSH TEM))
#(PUSH (CAR Z) L)))
(COND (SLOTLOC (RPLACA SLOTLOC SVSLT) (SETQ SLOTLOC NIL SVSLT NIL))))
;;; AT THIS POINT, L IS THE LIST OF GOODIES TO BE LOADED
(DO Z L (CDR Z) (NULL Z)
(COND ((NOT (ATOM (CDAR Z))) ;LIKE (G0001 CAR X . 3)
(SETQ TEM VL T2 (CARCDR (CAR Z) 1))
(COND ((NOT (EQ TEM VL)) (OPUSH T2 (LIST (CAAR Z)) NIL)) ;VL HACKERY
((CPUSH2 NIL T2))))
((AND (SETQ T2 (NUMBERP (SETQ TEM (ILOC0 (CAR Z) NIL))))
(< TEM 1)
(NOT (DVP TEM)))
(CONT TEM (CONS (CAAR Z) 'IDUP))) ;LIKE (X.N)
((OPUSH TEM
(COND ((AND T2 (NUMBERP (CDR (SETQ T2 (CONTENTS TEM))))) T2)
((CONS (CAAR Z) 'IDUP)))
NIL)))))
NIL
NIL
0
NIL
NIL ))
(DEFUN CPVRL NIL
(COND (LPRSL)
(T (SETQ LPRSL '(0 0 0))
(CNPUSH PVRL T)
(SETQ PRSSL (SLOTLISTCOPY))
(SETQ LPRSL (LIST (LENGTH REGPDL) (LENGTH FXPDL) (LENGTH FLPDL))))))
(DEFUN CNPUSH (L FL)
(AND L
(PROG (NN XN LN MODE LOC ITEM Z ZZ)
(DECLARE (FIXNUM NN XN LN))
(SETQ NN 0 XN 0 LN 0)
A (SETQ MODE (VARMODE (CAR L)))
(SETQ LOC (ILOC1 T (SETQ ITEM (CONS (CAR L) CNT)) MODE))
(COND ((OR LOC (AND MODE (ASSQ (CAR L) REGACS) (SETQ LOC (ILOC1 T ITEM NIL))))
(AND FL #(ACLOCP LOC) #(PUSH LOC ZZ)))
(T (RPLACD ITEM NIL)
(COND ((NULL MODE) #(PUSH ITEM REGPDL) (SETQ NN (1+ NN)))
((EQ MODE 'FIXNUM) #(PUSH ITEM FXPDL) (SETQ XN (1+ XN)))
(T #(PUSH ITEM FLPDL) (SETQ LN (1+ LN))))))
(AND (SETQ L (CDR L)) (GO A))
(AND (NOT (ZEROP NN)) (CNPUSH1 NN 0)) ;0 IS FOR P
(AND (NOT (ZEROP XN)) (CNPUSH1 XN 1)) ;1 IS FOR FXP
(AND (NOT (ZEROP LN)) (CNPUSH1 LN 2)) ;2 IS FOR FLP
(MAPC 'CPUSH ZZ)
(RETURN Z))))
(DEFUN CNPUSH1 (N PDL)
(DECLARE (FIXNUM N PDL MAX)) ;PDL IS THE NUMBER DESIGNATING WHICH PDL
(PROG (MAX) ;N IS THE AMOUNT TO BE PUSHED, AND MAX IS THE MAX BITE IN ONE CHUNK
(SETQ MAX (PVIA PDL 0))
A (COND ((> N MAX)
(OUTPUT (PVIA PDL MAX))
(SETQ N (- N MAX))
(GO A))
((> N 2) (OUTPUT (PVIA PDL N)))
((> N 0)
(OUTPUT (PVIA PDL 1))
(AND (= N 2) (OUTPUT (PVIA PDL 1)))))))
(DEFUN DIDUP (L)
(COND (L (COND ((EQ L CLPROGN))
((MEMQ PROGN L) (SETQ L CLPROGN)))
(DIDU1 REGACS L)
(DIDU1 NUMACS L)
(DIDU1 REGPDL L)
(DIDU1 FXPDL L)
(DIDU1 FLPDL L))))
(DEFUN DIDU1 (SLOT L)
(AND SLOT
(DO ZZ (ASSOCR 'IDUP SLOT) (ASSOCR 'IDUP (CDR ZZ)) (NULL ZZ)
(AND (OR (EQ L CLPROGN) (MEMQ (CAAR ZZ) L))
(RPLACA ZZ (CONS (CAAR ZZ) CNT))))))
(DEFUN DVP (I) (DVP1 (FIND I) I))
(DEFUN DVP1 (SL I)
;;; TELLS WHETHER ITEM MUST BE SAVED (AT THIS POINT). SHOULD NOT CHANGE SLOTX, EG BY CALLING FIND
(COND ((OR (NULL (CAR SL)) (EQ (CAAR SL) 'QUOTE) (EQ (CDAR SL) 'DUP)) NIL)
((MEMQ (CDAR SL) '(TAKEN IDUP)))
((DVP2 (CAR SL) I (VARBP (CAAR SL))))))
(DEFUN DVP2 (ITEM I VFL) ;VFL MUST BE RESULT OF VARBP
(COND (VFL (COND ((AND (EQ VFL 'SPECIAL)
(MEMQ (CDR ITEM) '(DUP NIL))) ;CURRENT HOME OF SPEC VAR
NIL)
((AND (NOT (EQ VFL 'SPECIAL)) ;CURRENT HOME OF LOCAL VAR
(OR (NULL (CDR ITEM)) (EQ (CDR ITEM) 'OHOME))) ; WHOSE TIME HAS NOT YET
(SETQ VFL (ASSQ (CAR ITEM) LOCVARS))
(OR (< CNT (CDR VFL)) (DVP4 ITEM I))) ; RUN OUT [OR IS STILL DVP4]
((NOT (NUMBERP (CDR ITEM)))
(BARF (LIST I ITEM) |WHASS HAPPNIN - DVP2|))
(#(ACLOCP I)
(SETQ VFL (GETMODE I)) ;VAR IN AC IS NOT DVP IF AN
(SETQ VFL #(PDLGET VFL)) ;IDUP OR SAME-COUNT COPY IS
(COND ((OR (CLMEMBER (CAR ITEM) 'IDUP VFL 'EQ) ;ON PDL
(CLMEMBER (CAR ITEM) (CDR ITEM) VFL '=))
NIL)
((DVP4 ITEM I))))
((DVP4 ITEM I))))
((ASSQ (CAR ITEM) LDLST)) ;INTERNAL COMPUTATION QUANTITY ON LDLST
(VL (DVP3 (CAR ITEM) VL)))) ;VARLIST CROSSINGS
(DEFUN DVP3 (VAR L)
(AND L
(SETQ L (DO ZZ L (CDR ZZ) (NULL ZZ) ;LOOK FOR CROSSING FOR THIS VAR
(AND (EQ VAR (CAAR ZZ)) (RETURN ZZ))))
((LAMBDA (XTN LL)
(COND ((AND LL (NOT (ASQSLT XTN)))) ;A PRIMARY, NEEDED CROSSING
((NULL (CDR L)) NIL) ;NO MORE POTENTIAL CROSSINGS
((AND (NULL LL) (DVP3 XTN (CDR L)))) ;LOOK FOR "GRANDSONS"
((DVP3 VAR (CDR L))))) ;LOOK FOR ADDITIONAL DIRECT "SONS"
(CDAR L) (ASSQ (CDAR L) LDLST))))
(DEFUN DVP4 (ITEM I)
(AND (ASSQ (CAR ITEM) LDLST) ;BASIC VAR DVP UTILIZING LDLST
((LAMBDA (MODE VAR)
(DO ((Z LDLST (CDR Z)) ;IF ANY ITEM ON LDLST NEEDS DATA
(PDLP (AND #(PDLLOCP I) (NUMBERP (CDR ITEM))))
(FL (AND MODE (ASSQ VAR REGACS)))
(TEM))
((NULL Z))
(AND (EQ (CAAR Z) VAR)
(NUMBERP (SETQ TEM (COND (FL #(ILOCNUM (CAR Z) NIL))
((ILOC1 T (CAR Z) MODE)))))
(OR (= I TEM) ;IF (X.4) IN BOTH PDL AND AC AND
(AND PDLP ;SOMEBODY ON LDLST WANTS EITHER
(> TEM 0) ;SLOT, THEN PDL SLOT IS DVP
(EQUAL ITEM (GCONTENTS TEM))))
(RETURN T))))
(VARMODE (CAR ITEM)) (CAR ITEM))))
(DEFUN EASYGO () ;SHOULD BE NOTHING ON LDLST EXCEPT WHAT WAS THERE
(AND (EQ PROGP LDLST) ;UPON ENTRY TO THE PROG
(NULL GOBRKL) ;NOT BE IN LAMBDA REQUIRING SPECIAL UNBIND
(= (LENGTH REGPDL) (CAR LPRSL)) ; AND NOT UNDER CATCH OR ERRSET
(= (LENGTH FXPDL) (CADR LPRSL)) ;SLOTLIST NOT NEED RESTORE TO PROG LEVEL
(= (LENGTH FLPDL) (CADDR LPRSL))))
(DEFUN FIND (N)
(SETQ SLOTX (COND ((PLUSP N)
(COND (#(NUMACP N) (SETQ N (- N #(NUMVALAC))) NUMACS)
(T (SETQ N (1- N)) REGACS)))
((NOT #(NUMPDLP N)) (SETQ N (- N)) REGPDL)
(#(FLPDLP N) (SETQ N (- #(FLP0) N)) FLPDL)
(T (SETQ N (- #(FXP0) N)) FXPDL)))
(COND ((ZEROP N) SLOTX)
((SETQ SLOTX (NCDR SLOTX N)))))
(DEFUN FLUSH-SPL-NILS ()
(AND SPLDLST
(PROG (L OL)
A (AND (NULL (CAR SPLDLST)) (SETQ SPLDLST (CDR SPLDLST)) (GO A))
(SETQ OL (SETQ L SPLDLST))
B (AND (NULL (SETQ L (CDR L))) (RETURN SPLDLST))
(COND ((NULL (CAR L)) (RPLACD OL (CDR L)))
((SETQ OL L)))
(GO B))))
(DEFUN FRACF NIL
((LAMBDA (N)
(COND ((ZEROP N) (SETQ SLOTX REGACS) (CPUSH1 1 NIL NIL) 1)
(N)))
(FRAC)))
(DEFUN FRAC NIL
(COND ((NULL (CAR (SETQ SLOTX REGACS))) 1) ;THIS BLETCHEROUS CODE IS
((NULL (CAR #(POP SLOTX))) 2) ;HERE PURELY FOR SPEED
((NULL (CAR #(POP SLOTX))) 3) ;REASONS, SINCE CALLS TO
((NULL (CAR #(POP SLOTX))) 4) ;THESE FUNCTIONS ARE SO FREQUENT
((NULL (CAR #(POP SLOTX))) 5)
((DO N (PROG2 (SETQ SLOTX REGACS) 1)
(PROG2 #(POP SLOTX) (1+ N))
(> N #(NACS))
(AND (NOT (DVP1 SLOTX N)) (RETURN N))))
(0)))
(DECLARE (AND (< #(NACS) 5) (BARF NIL |FRACB IS LOSING|)))
(DEFUN FRACB NIL
((LAMBDA (Y)
(COND ((NULL (CADR Y)) (SETQ SLOTX (CDDR SLOTX)) 5) ;TRIES EMPTY 5,4,3 FIRST IN THAT ORDER,
((NULL (CAR Y)) (SETQ SLOTX (CDR SLOTX)) 4) ;THEN TRIES NON-DVP AC IN BACKWARDS ORDER
((NULL (CAR SLOTX)) 3) ;ASSUMING SLOT IS BEING USED FOR TEMPS
((NOT (DVP1 (CDR Y) 5)) (SETQ SLOTX (CDR Y)) 5)
((NOT (DVP1 Y 4)) (SETQ SLOTX Y) 4)
((NOT (DVP1 SLOTX 3)) 3)
((NOT (DVP1 (SETQ SLOTX (CDR REGACS)) 2)) 2)
((1FREE) (SETQ SLOTX REGACS) 1)
(0)))
(CDR (SETQ SLOTX (CDDR REGACS))))) ;THIS HAD BETTER YIELD SLOTX = (FIND 3)
(DEFUN FRAC1 NIL
((LAMBDA (AC)
(COND ((1FREE) (SETQ SLOTX REGACS) 1)
((NOT (ZEROP (SETQ AC (FRACB)))) AC)
(T (SETQ SLOTX REGACS) (CPUSH1 1 NIL NIL) 1)))
0))
(DEFUN FRAC5 NIL
((LAMBDA (N) (COND ((NOT (ZEROP N)) N)
(T (SETQ SLOTX (CDDDDR REGACS)) ;MUST BE SET SLOTX = (FIND 5)
(CPUSH1 #(NACS) NIL NIL)
#(NACS))))
(FRACB)))
(DEFUN FREEREGAC (F)
((LAMBDA (AC) (COND ((ZEROP AC) (BARF NIL |NO FREE ACS - FREEREGAC|) 0)
(AC)))
(COND ((EQ F 'FRAC) (FRAC)) ((FRACB)))))
(DEFUN FREEIFYNUMAC NIL
(OR (NOT (ZEROP (FREENUMAC1))) ;INSURE THAT THERE IS AT LEAST
(PROG2 (CLEARACS ##(- (NUMNACS)) NIL T) ;ONE FREE NUMAC
(NOT (ZEROP (FREENUMAC1))))
(FREENUMAC0)))
(DEFUN FREENUMAC NIL ((LAMBDA (AC) (AND (ZEROP AC) (SETQ AC (FREENUMAC0))) AC)
(FREENUMAC1)))
(DEFUN FREENUMAC1 NIL
(COND ((AND (NULL (CAR (SETQ SLOTX NUMACS))) (NOT (= TAKENAC1 #(NUMVALAC))))
#(NUMVALAC))
((AND (NULL #(POP SLOTX)) (NOT (= TAKENAC1 (1+ #(NUMVALAC)))))
(1+ #(NUMVALAC)))
((AND (NULL #(POP SLOTX)) (NOT (= TAKENAC1 (+ #(NUMVALAC) 2))))
(+ #(NUMVALAC) 2))
((DO I (PROG2 (SETQ SLOTX NUMACS) #(NUMVALAC))
(PROG2 #(POP SLOTX) (1+ I))
(NULL SLOTX)
(AND (NOT (= I TAKENAC1)) (NOT (DVP1 SLOTX I)) (RETURN I))))
(0)))
(DEFUN FREENUMAC0 NIL
(SETQ SLOTX NUMACS)
(COND ((= TAKENAC1 #(NUMVALAC))
(SETQ SLOTX (CDR SLOTX))
(CPUSH1 (1+ #(NUMVALAC)) NIL NIL)
(1+ #(NUMVALAC)))
(T (CPUSH1 #(NUMVALAC) NIL NIL)
#(NUMVALAC))))
(DEFUN FUNMODE (F)
(DO Y MODELIST (CDR Y) (NULL Y)
(AND (NOT (ATOM (CAAR Y)))
(EQ (CAAAR Y) F)
(RETURN (CDAR Y)))))
(DEFUN GCDR (F L)
; GENERALIZED CDR
(PROG NIL
(AND (NULL L) (RETURN NIL))
##(COND ((NOT (MEMQ COMPILER-STATE '(NIL TOPLEVEL)))
'(SETQ F (GET F 'SUBR)))
('B))
A (COND ((AND L (NOT ##(COND ((NOT (MEMQ COMPILER-STATE '(NIL TOPLEVEL)))
'(SUBRCALL T F L))
('(FUNCALL F L)))))
#(POP L)
(GO A)))
(RETURN L)))
;;; GET CONTENTS, BUT DONT CHANGE SLOTX
(DEFUN GCONTENTS (X) ((LAMBDA (SVSLT) (PROG2 NIL (CONTENTS X) (SETQ SLOTX SVSLT))) SLOTX))
(DEFUN GENTAG (TAG TNAME)
(COND (TAG)
(T (SETQ TAG (GENSYM))
(SETQ GL (CONS (CONS NIL (SET TNAME TAG))
GL))
(PUTPROP TAG T 'USED)
TAG)))
(DEFUN GETMODE (N)
(COND ((PLUSP N) (GETMODE0 N #(NUMACP N) T))
((NOT #(NUMPDLP N)) NIL)
(#(FLPDLP N) 'FLONUM)
('FIXNUM)))
(DEFUN GETMODE0 (N ACP SHEE-IT)
(COND ((AND ACP (CAR #(ACSMODESLOT N))))
(((LAMBDA (TEMP)
(COND ((NULL (SETQ TEMP (GCONTENTS N)))
(BARF N |NO THING - GETMODE|))
((EQ (CAR TEMP) 'QUOTE)
(CAR (MEMQ (TYPEP (CADR TEMP)) '(FIXNUM FLONUM))))
((NUMERVARP (CAR TEMP)))
((AND ACP (NOT (VARBP (CAR TEMP))))
(COND (FIXSW 'FIXNUM)
(FLOSW 'FLONUM)
(SHEE-IT (BARF N |NO MODE - GETMODE|) NIL)))))
NIL))))
;;; INTERNAL LOCATORS - RETURN ONE OF
;;; NIL ;NOT FOUND
;;; ((QUOTE MUMBLE) . NIL) ;QUOTED THING
;;; (SPECIAL FOO) ;CURRENT VALUE OF SPECIAL VAR
;;; 1 => 5 ;QUANTITY IN REGACS
;;; 7 => 11 ;" " NUMACS
;;; -4777 => 0 ;" " REGPDL
;;; -7777 => -5000 ;" " FXPDL
;;; -INF => -10000 ;" " FLPDL
(DEFUN ILOC0 (X MODE)
;$ SHOULD NOT CHANGE SLOTX, EG BY CALLING FIND , OR CONT, OR CONTENTS
; INTERNALLY LOCATED ? SPECIAL VALUE CELLS, QUOTE STUFF, AND SLOTLIST ENTRY S
; ARE INTERNAL PLACES ACCEPTABLE RETURN S BEST OF THESE IF X IS SOMEWHERE THEREIN
; OTHERWISE NIL
(COND ((EQ (CAR X) 'QUOTE) (LIST X))
((ILOC1 (VARBP (CAR X)) X MODE))))
(DEFUN ILOC1 (FL X MODE)
(DO ((I 1 (ADD1 I)) (Y #(ACSGET MODE) (CDR Y))
(ENDFLAG) (T1) (BESTLOC 0) (BESTCNT 0))
((COND ((NULL Y)
(COND (ENDFLAG)
(T (SETQ ENDFLAG T)
(NULL (SETQ Y #(PDLGET MODE)))))))
(COND ((NOT (ZEROP BESTCNT))
(CONVNUMLOC (COND ((< BESTLOC (SETQ T1 #(NACSGET MODE))) BESTLOC)
((- T1 BESTLOC)))
MODE))
(MODE NIL)
((AND FL #(SPECIALP (CAR X))) (LIST 'SPECIAL (CAR X)))
((AND (NOT FL) (SETQ FL (ASSOCR (CAR X) VL)))
(ILOC1 NIL (CONS (CAAR FL) (CDR X)) NIL))))
(AND (CAR Y)
(EQ (CAAR Y) (CAR X))
(COND ((MEMQ (CDAR Y) '(NIL DUP IDUP))
(COND ((ZEROP BESTCNT)
(SETQ BESTLOC I BESTCNT 105105)
(COND ((NOT FL) (SETQ Y NIL ENDFLAG T))))))
; THE FIRST INSTANCE IN THE SLOTLIST OF A GENSYM QUANTITY WILL BE THE RIGHT ONE
((AND FL (CDR X)
(NUMBERP (SETQ T1 (COND ((EQ (CDAR Y) 'OHOME) (GET (CAAR Y) 'OHOME))
((CDAR Y)))))
(NOT (< T1 (CDR X)))
(OR (ZEROP BESTCNT) (> BESTCNT T1)))
(SETQ BESTCNT T1 BESTLOC I))))))
(DEFUN ILOC2 (FL V TYPE)
(COND ((AND (NULL FL) (EQ (CAR V) 'QUOTE)) (LIST V))
((ILOC1 FL V TYPE))
((AND TYPE (ILOC1 FL V NIL)))
((AND (NULL FL) (ASSQ (CAR V) SPLDLST)) NIL)
(T (BARF V |LOST? - ILOC2|) NIL)))
(DEFUN ILOCMODE (ITEM ACORFUN TYPE)
(COND ((EQ (CAR ITEM) 'QUOTE) (LIST ITEM))
((PROG (Z NPZ ZZ ATP FL)
(SETQ ATP (ATOM TYPE) FL (VARBP (CAR ITEM)))
(SETQ Z (ILOC1 FL ITEM (AND ATP TYPE)))
(COND ((NULL Z)
(RETURN (COND ((COND ((AND ATP TYPE) (SETQ ZZ (ILOC1 FL ITEM NIL)))
((AND ATP ACORFUN) NIL)
((SETQ ZZ (COND (FL (SETQ NPZ (VARMODE (CAR ITEM)))
(COND ((NULL NPZ) NIL)
((ILOC1 T ITEM NPZ))
((ILOC1 T
ITEM
(COND ((EQ NPZ 'FIXNUM)
'FLONUM)
('FIXNUM))))))
((ILOC1 T ITEM 'FIXNUM))
((ILOC1 T ITEM 'FLONUM))))))
ZZ)
((NULL ACORFUN) NIL)
((SETQ ZZ (ASSQ (CAR ITEM) SPLDLST)) (CARCDR ZZ ACORFUN))
((BARF ITEM |LOST DATUM - ILOCMODE|)))))
((COND ((OR (NULL TYPE) (NULL FL))) ;TEDIOUS DECISION AS TO WHETHER OR NOT TO
((VARMODE (CAR ITEM)) NIL) ;TRY THE OTHER AREAS
((NOT (ASSQ (CAR ITEM) NUMACS))) ;NUMVARS LOCATABLE IN REGAREA MUST BE SOUGHT IN
(ATP NIL) ;THE NUMWORLD, AND ILOCNUMS MIGHT WANT TO CHECK
((NULL (CAR TYPE)))) ;THE NUMACS
(RETURN Z))
((PROG2 (SETQ NPZ (NUMBERP Z))
ATP) ;TYPE = FIXNUM [OR FLONUM]
(AND (OR (NOT NPZ)
(NOT (NUMBERP (SETQ ZZ (ILOC1 FL ITEM NIL)))))
(RETURN Z))
(SETQ ZZ (PROG2 NIL Z (SETQ Z ZZ))))
(T (AND (COND ((NULL (CAR TYPE)) (NOT NPZ)) ;(NIL FIXNUM FLONUM) => CALL BY ILOCREG
((NOT NPZ) (NOT (EQ (CAR Z) 'SPECIAL))))
(RETURN Z)) ;(FIXNUM FLONUM) => CALL BY ILOCNUM
(SETQ ZZ (COND ((ILOC1 FL ITEM 'FIXNUM))
((ILOC1 FL ITEM 'FLONUM))
(T (RETURN Z))))
(AND (NOT NPZ) (RETURN ZZ))))
;SO A CALL FOR ILOCREG OR ILOCNUM HAS RESULTED IN FINDING COPIES IN BOTH
;THE NUM WORLD AND THE REG WORLD. SO WE HAVE TO ASCERTAIN WHICH COPY IS BEST
;Z HOLDS RESULT OF (ILOC0 ITEM NIL), I.E. THE REG WORLD LOC, AND
;ZZ THAT FOR (ILOC0 ITEM 'FIXNUM) [OR 'FLONUM], THE NUM WORLD LOC
;RCNT IS THE TIME-COUNT FOR THE REG-WORLD SLOT, NCNT FOR THE NUMBER WORLD
(RETURN ((LAMBDA (RCNT NCNT)
(AND (NOT (NUMBERP RCNT)) (SETQ RCNT NIL))
(AND (NOT (NUMBERP NCNT)) (SETQ NCNT NIL))
(COND ((AND (NOT NCNT) (NOT RCNT))
(COND ((NUMBERP ACORFUN) (COND (#(NUMACP ACORFUN) ZZ) (Z)))
((AND FL (VARMODE (CAR ITEM))) ZZ)
((NULL (CAR TYPE)) Z)
(ZZ)))
((AND NCNT RCNT) (COND ((< RCNT NCNT) Z) (ZZ))) ;PREFER LOWER OF TWO COUNTS
((AND RCNT (< RCNT CNT)) Z) ;PREFER A COUNT TO A HOME
(ZZ))) ;IF COUNT IS ACCEPTABLE
(CDR (GCONTENTS Z))
(CDR (GCONTENTS ZZ))))))))
(DEFUN ITEML (Y PROP)
; ITEML COMPILES AN ITEMLIST AND RETURNS A LIST OF THE COMPILED ARGUMENTS
; (INTERNAL NAMES THEREFOR, THAT IS) IN REVERSE ORDER
(DO ((AC 1 (ADD1 AC)) (Y Y (CDR Y))
(Z) (ITEM) (LOC) (ARGNO 1) (PNOB) (EFFS)
(PROP (AND PROP (CDDR PROP)) (AND PROP (CDR PROP))))
((NULL Y) Z)
(SETQ ARGNO (COND ((AND PROP (CAR PROP) (NOT (EQ (CAR PROP) T)))
#(NUMVALAC))
(AC)))
(SETQ PNOB (NOT (AND PROP (EQ (CAR PROP) T))))
#(PUSH (SETQ ITEM (COMP0 (CAR Y))) Z)
(AND (= ARGNO #(NUMVALAC))
(NUMBERP (SETQ LOC (ILOC0 ITEM (CAR PROP))))
#(NUMACP LOC)
(SETMODE LOC (CAR PROP)))))
(DEFUN L/.LE/. (L LL) ;LENGTH L LESS-THAN-OR-EQUAL-TO LENGTH LL
(PROG ()
A (AND (NULL L) (RETURN (COND (LL 'LESSP) ('EQUAL))))
(AND (NULL LL) (RETURN NIL))
(SETQ L (CDR L) LL (CDR LL))
(GO A)))
(DEFUN L2F (X)
(COND ((OR (NULL X) (NULL (CDR X))) X)
(T (SETQ X (REVERSE X)) (RPLACD X (NREVERSE (CDR X))))))
(DEFUN LSUB (L LL)
(COND ((NULL LL) L)
((NOT (MEMQ (CAR LL) L)) (LSUB L (CDR LL)))
((MAPCAN '(LAMBDA (X) (COND ((MEMQ X LL) NIL)
((LIST X))))
L))))
(DEFUN LADD (L LL)
(COND ((NULL L) LL)
((LADD (CDR L) (ADD (CAR L) LL)))))
(DEFUN LAND (L LL)
(COND ((OR (NULL L) (NULL LL)) NIL)
((NOT (MEMQ (CAR LL) L)) (LAND L (CDR LL)))
((MAPCAN '(LAMBDA (X) (AND (MEMQ X L) (LIST X))) LL))))
(DEFUN LJOIN (L LL) ;LIKE APPEND, BUT TRIES INTERCHANGING ARGS
(COND ((NULL L) LL) ;IF THAT WILL REDUCE CONSING
((NULL LL) L)
(T (AND (< (LENGTH LL) (LENGTH L)) (SETQ L (PROG2 NIL LL (SETQ LL L))))
(APPEND L LL))))
(DEFUN LEVELTAG NIL
((LAMBDA (Y)
(PUTPROP Y (SLOTLISTCOPY) 'LEVEL) Y)
(GENSYM)))
(DEFUN LEVEL (TAG)
(COND ((GET TAG 'LEVEL))
((ASSOCR TAG GL) PRSSL)
((BARF TAG |TAG WITH NO SLOTLIST LEVEL|))))
(DEFUN LOADACS (X HLAC PROP)
(AND PROP
(SETQ PROP (CAR PROP))
(DO I (- HLAC (LENGTH PROP)) (1- I) (SIGNP LE I)
#(PUSH NIL PROP)))
(DO ((X X (CDR X)) (AC HLAC (SUB1 AC)) (PROP PROP (AND PROP (CDR PROP))))
((ZEROP AC))
(COND ((OR (NULL PROP) (NULL (CAR PROP)) (EQ (CAR PROP) T)
(REGADP #(ILOCREG (CAR X) AC)))
(LOADAC (CAR X) AC (AND PROP (EQ (CAR PROP) T))))
((MAKEPDLNUM (CAR X) AC)))))
(DEFUN LOADAC (VAR AC CONSFL)
((LAMBDA (Z)
(COND ((AND CONSFL
(NOT #(NUMACP AC))
(OR (NOT (REGADP Z))
(MEMQ (CAR VAR) UNSFLST)
(AND (NOT (EQ (CAR VAR) 'QUOTE))
(NOT #(SPECIALP (CAR VAR)))
(VARMODE (CAR VAR)))))
(SETQ VAR (P2NUMCONS VAR Z))
(AND (NULL (SETQ Z (ILOC0 VAR NIL))) (BARF VAR |P2NUMCONS LOSS - LOADAC|)))
(T (REMOVEB VAR)))
(COND (#(NUMACP AC) (LOCINNUMAC0 VAR AC Z 'REMOVEB))
((NOT (NUMBERP Z)) ;((QUOTE STUFF)) OR (SPECIAL VAR)
(CPUSH AC) ;SETS SLOTX TO (FIND AC)
(COND ((AND (NOT (EQ (CAR Z) 'SPECIAL)) ;IF QUOTE STUFF TO BE LOADED
(CAR SLOTX) ;IS ALREADY THERE THEN DO NOTHING
(EQ (CAAR SLOTX) 'QUOTE)
(EQUAL VAR (CAR SLOTX))))
((AND (NOT (EQ (CAR Z) 'SPECIAL))
(MEMQ (CADAR Z) '(T NIL)))
(COND ((CADAR Z) (OUTPUT (CADR (BOLA AC)))) ;(MOVEI AC 'T)
((AND (NOT ATPL) ;CONVERT (MOVEI AD 'NIL)
(EQ (CAR LOUT) 'MOVEI) ; (MOVEI AC 'NIL)
(NOT (ATOM (CADDR LOUT))) ;INTO (SETZB AD AC)
(QNILP (CADDR LOUT)))
((LAMBDA (AD)
(SETQ LOUT (SETQ ATPL 'FOO))
#(OUTFS 'SETZB AD AC))
(CADR LOUT)))
(T (OUTPUT (CAR (CDDDDR (BOLA AC))))))) ;(MOVEI AC 'NIL)
(T (OUT1 'MOVE AC Z)))
(CONT AC (COND ((EQ (CAR Z) 'SPECIAL) (LIST (CAR VAR)))
(VAR))))
(((LAMBDA (Z-IN-ACP)
(COND ((AND Z-IN-ACP
(NOT #(NUMACP Z))
(EQ (CDAR (FIND Z)) 'DUP) ;SLOTX IS WHERE Z IS IN AC
REGPDL
(EQ (CAAR SLOTX) (CAAR REGPDL)) ;OF PDL AND DUP IN AC
(NOT (VARBP (CAAR SLOTX))) ;GENSYM QUANTITY ON TOP
(NOT (DVP1 SLOTX 0))) ;WAS FOUND
(RPLACA SLOTX NIL) ;CHANGE Z TO TOP OF PDL
(SETQ Z 0)))
(COND ((AND Z-IN-ACP (= Z AC)) (CPUSH AC))
((NOT (REGADP Z)) #(PUSH VAR LDLST) (MAKEPDLNUM VAR AC))
(T ((LAMBDA (ACLOC DAC DATAORG DOD)
(COND ((AND (ZEROP Z) (NOT DOD) (NOT DAC))
(OPOP AC NIL)
(RPLACA ACLOC DATAORG))
((AND (NOT DOD)
(CAR ACLOC)
(COND ((ZEROP Z))
(#(PDLLOCP Z)
(NOT (AND DAC (VARBP (CAAR ACLOC)))))
((PLUSP HLAC) ;SAYS CALL FROM LOADACS
(OR (> Z HLAC) (< Z AC)))))
(OUT1 'EXCH AC Z)
(CONT Z (CAR ACLOC))
(RPLACA ACLOC DATAORG))
(T (AND DAC
(PROG2 (FIND AC) (EQ (CPUSH1 AC NIL Z) 'PUSH))
#(PDLLOCP Z)
(SETQ Z (ILOC0 VAR NIL)))
(COND ((AND Z-IN-ACP
(NOT ATPL)
(EQ (CAR LOUT) 'POP)
(= Z (CADDR LOUT))
(EQ (CADR LOUT) 'P))
(SETQ LOUT (SETQ ATPL 'FOO))
(CONT Z NIL)
(COND (DOD #(OUTFS 'MOVE AC 0 'P)
#(PUSH DATAORG REGPDL))
(#(OUTFS 'POP 'P AC))))
(T (COND ((AND Z-IN-ACP
(> Z AC)
(PLUSP HLAC)
(NOT (> Z HLAC))
(NOT ATPL)
(EQ (CAR LOUT) 'EXCH)
(EQUAL AC (CADDR LOUT))
(EQUAL Z (CADR LOUT)))
(SETQ LOUT (SETQ ATPL 'FOO))
(OUT1 'MOVE Z AC))
(T (OUT1 'MOVE AC Z)))))
(RPLACA ACLOC
(COND ((NUMBERP (CDR DATAORG)) DATAORG)
((CONS (CAR DATAORG) 'DUP)))))))
(FIND AC) ;FIND AND CONTENTS SET SLOTX
(DVP1 SLOTX AC)
(CAR (FIND Z))
(DVP1 SLOTX Z)))))
#(ACLOCP Z)))))
#(ILOCREG VAR AC)))
(DEFUN LOCINNUMAC (ITEM AC) (LOCINNUMAC0 ITEM AC NIL 'REMOVEB))
(DEFUN LOCINNUMAC0 (ITEM AC LOC RMFLG)
(PROG (ACFLG MODE)
(SETQ ACFLG T)
(AND (NULL LOC)
(SETQ LOC #(ILOCNUM ITEM (COND ((ZEROP AC) (SETQ ACFLG NIL) 'FREENUMAC)
(T AC)))))
(COND ((EQ RMFLG 'REMOVE) (REMOVE ITEM)) ((REMOVEB ITEM)))
(COND ((REGADP LOC)
(AND (NOT ACFLG) (SETQ AC (FREENUMAC)))
(AND (NUMBERP LOC) (SETQ ITEM (CONTENTS LOC)))
(GO REG)))
(COND ((AND #(ACLOCP LOC) (OR (NOT ACFLG) (= LOC AC)))
(CPUSH LOC)
(RETURN LOC)))
(SETQ ITEM (CONTENTS LOC))
(AND #(NUMPDLP LOC) (SETQ MODE (GETMODE LOC))) ;A NUMPDL LOC
(COND (ACFLG (FIND AC) (SETQ ACFLG (EQ (CPUSH1 AC NIL LOC) 'PUSH)))
(T (AND (ZEROP (SETQ AC (FREENUMAC1)))
(SETQ ACFLG T)
(SETQ AC (FREENUMAC0)))))
(AND ACFLG ;SIGNIFIES A "PUSH" DONE
MODE ;AND THAT LOC IS A NUMPDL
(EQ MODE (GETMODE0 AC T T)) ;SO WHICH PDL WAS PUSHED?
(SETQ LOC (ILOC0 ITEM MODE)))
(COND ((AND (OR (= LOC #(FLP0)) (= LOC #(FXP0))) ;LOC IS TOP SLOT OF A NUMPDL
(NOT (DVP LOC))) ;AND CAN BE POPPED
(OPOP AC MODE))
(T (AND (NULL MODE) ;IF LOC BE NUMPDLP, THEN MODE
(SETQ MODE (GETMODE0 LOC T NIL))) ;WILL ALREADY HAVE BEEN SET NON-NIL
(OUT1 'MOVE AC LOC)))
(GO END)
REG (SETQ ACFLG (CAR ITEM))
(COND ((EQ ACFLG 'SPECIAL) (SETQ ACFLG (CADR ITEM))))
(SETQ MODE (COND ((AND (EQ ACFLG 'QUOTE) (SETQ MODE (TYPEP (CADR ITEM))))
MODE)
((VARMODE ACFLG))
(FIXSW 'FIXNUM)
(FLOSW 'FLONUM)))
(COND ((AND (NOT (ATOM LOC)) (EQ (CAR LOC) 'SPECIAL))
(SETQ ITEM (CDR LOC))))
(FIND AC)
(CPUSH1 AC NIL LOC)
(OUT2 '(MOVE) AC LOC)
END (CONT AC (COND ((OR (NULL (CDR ITEM)) (EQ (CDR ITEM) 'DUP) (EQUAL (CDR ITEM) CNT))
(CONS (CAR ITEM) 'DUP))
((OR (NUMBERP (CDR ITEM)) (EQ (CAR ITEM) 'QUOTE)) ITEM)
((NCONS (CAR ITEM)))))
(SETMODE AC MODE)
(RETURN AC)))
(DEFUN LOCINAC (X FUN FL Z)
; PLACE A QUANTITY X IN SOME REGULAR ACCUMULATOR, REMOVE ING FROM LDLST
; "FUN" IS ADVICE OR HEURISTIC AS TO WHICH ACC IS PREFERABLE,
; AND CAN BE "FRACB", "NIL", "FREACB", OR SOME SPECIFIC ACC NUMBER.
; FL SAYS WHETHER OR NOT PDL NO IS ACCEPTABLE [NIL => YES]
; Z IS CURRENT LOCATION OF X; NIL => LOOK IT UP AGAIN
(AND (NULL Z) (SETQ Z #(ILOCF X)))
(COND ((AND (NUMBERP Z) #(REGACP Z)) (REMOVE X) (CPUSH Z))
((NOT (ZEROP (SETQ Z (COND ((EQ FUN 'FRACB) (FRACB))
((OR (NULL FUN) (EQ FUN 'FREACB)) #(FREACB))
((AND (NUMBERP FUN) #(REGACP FUN)) FUN)
(T 0)))))
(LOADAC X Z FL))
(T (SETQ Z 0)))
Z)
(DEFUN MAKEPDLNUM (ITEM AC)
((LAMBDA (LOC)
((LAMBDA (MODE NEWLOC TEM)
(COND (#(ACLOCP LOC)
(SETQ TEM (CONTENTS LOC))
(CPUSH LOC)
(CONT LOC NIL)
(SETQ NEWLOC (ILOC0 ITEM MODE))
(SETQ ITEM TEM)
(COND ((NULL NEWLOC) (OPUSH LOC ITEM MODE)
(SETQ NEWLOC (CONVNUMLOC 0 MODE))))
(CONT LOC (CONS (CAR ITEM) 'DUP))))
(OUT1 'MOVEI AC NEWLOC)
(AND (NOT (VARBP (CAR ITEM)))
(NOT (CLMEMBER (CAR ITEM) MODE MODELIST 'EQ))
#(PUSH (CONS (CAR ITEM) MODE) MODELIST)))
(GETMODE LOC) LOC NIL)
(CONT AC (CONS (CAR ITEM) 'DUP)))
(PROG2 (CPUSH AC) #(ILOCNUM ITEM AC) (REMOVEB ITEM))))
(DEFUN NCDR (EXP N)
(PROG NIL
A (COND ((OR (NULL EXP) (ZEROP N)) (RETURN EXP))
((> N 4) (SETQ N (- N 5) EXP (CDDDDR (CDR EXP))))
(T (SETQ N (1- N) EXP (CDR EXP))))
(GO A)))
(DEFUN NX2LAST (X)
(COND ((NULL (CDR X)) NIL) ;REMEMBER, CDR[NIL]=NIL
((PROG (ZZ)
A (SETQ ZZ X)
(AND (NULL (CDR (SETQ X (CDR X)))) (RETURN (CAR ZZ)))
(GO A)))))
(DEFUN OJRST (TAG DONT) (OUTJ0 'JRST 0 TAG T DONT))
(DEFUN OPUSH (X ITEM MODE)
(PROG (TEMP OP)
(SETQ OP (COND ((AND (NULL (SETQ TEMP (REGADP X))) (NULL MODE))
(BARF X |PUSH P 7 LOSSAGE|))
((AND TEMP MODE) '(PUSH))
(T 'PUSH)))
(COND ((AND MODE (NOT (ATOM X)) (NOT (ATOM (CAR X)))
(EQ (CADR X) 'QUOTE) (NUMBERP (SETQ TEMP (CADAR X))))
(SETQ X (LIST '% TEMP))
(SETQ OP 'PUSH)))
(OUT2 OP
(COND ((EQ MODE 'FIXNUM) #(PUSH ITEM FXPDL) 'FXP)
((NULL MODE) #(PUSH ITEM REGPDL) 'P)
(T #(PUSH ITEM FLPDL) 'FLP))
X)))
(DEFUN OSPB (TLOC VAR)
((LAMBDA (N)
#(OUTFS N TLOC (LIST 'SPECIAL VAR)))
(COND ((NULL TLOC) (SETQ TLOC 0))
((PLUSP TLOC) 0)
(T (SETQ TLOC (ABS TLOC)) 7←41))))
(DEFUN OPUSHS (V) (OPUSH (LIST 'SPECIAL V) (CONS V CNT) (VARMODE V)))
(DEFUN OPOP (X MODE)
((LAMBDA (PDL)
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'PUSH)
(EQ (CADR LOUT) PDL)
#(ACLOCP (CADDR LOUT)))
((LAMBDA (AC)
(SETQ LOUT (SETQ ATPL 'FOO))
(COND ((AND (SIGNP G X) (= X AC)) (WARN AC |PUSHPOP - OPOP|))
(T (OUT1 'MOVEM AC X))))
(CADDR LOUT)))
(T (OUT1 'POP PDL X)))
(AND MODE
#(ACLOCP X)
(SETMODE X MODE))
(SHRINKPDL 1 MODE))
#(PDLAC MODE)))
(DEFUN OUTFUNCALL (OP AC FUN)
((LAMBDA (PROP NUMFL)
(COND ((AND (OR #(NUMACP ARGNO) PNOB EFFS)
(OR (SETQ PROP (GET FUN 'NUMFUN))
(DO Z MODELIST (CDR Z) (NULL Z)
(AND (EQ FUN (CAAAR Z))
(NULL (CDAAR Z))
(RETURN (SETQ PROP (CDAR Z))))))
(CADR PROP))
(SETQ NUMFL T)
(SETQ OP (CDR (ASSQ OP '((CALL . NCALL) (JCALL . NJCALL)
(CALLF . NCALLF) (JCALLF . NJCALF)))))))
#(OUTFS OP AC (LIST 'QUOTE FUN))
(COND (NUMFL (SETMODE #(NUMVALAC) (CADR PROP))
#(NUMVALAC))
(1)))
NIL NIL))
(DEFUN OUTG (X)
(OUTPUT (CAR X))
(DO X (CDR X) (CDR X) (NULL X)
#(OUTFS 'CAIN 1 (LIST 'QUOTE (CAAR X)))
#(OUTFS 'JUMPA 0 (CDAR X)))
(OUTPUT '(PUSHJ P *UDT))
#(OUTFS 'JUMPA 0 (CAR X))
(OUTPUT 'FOO))
(DEFUN COUTPUT (X)
(COND (FASLPUSH #(PUSH X LAPLL))
((ATOM X)
(COND ((EQ X GOFOO) (TYO 13.)) ;SPECIAL SIGNAL FOR CR
((EQ X NULFU) (TYO 32.)) ;SIGNAL FOR SPACE
(T (PRIN1 X))))
((AND (EQ (CAR X) 'QUOTE) (NULL (CDDR X)))
(COND ((AND (NOT (ATOM (CADR X)))
(OR (EQ (CAADR X) SQUID) (EQ (CDADR X) GOFOO)))
((LAMBDA (Y)
(COND ((OR (EQ (CDR Y) GOFOO)
(NOT (EQ (CADR Y) MAKUNBOUND)))
(PRINC '/(EVAL/ )
(COUTPUT (CAADR X))
(PRINC '/)))
(T (PRINC 'MAKUNBOUND))))
(CADR X)))
(T (TYO 39.) (COUTPUT (CADR X)))))
(T (PROG ()
(TYO 40.)
A (COUTPUT (CAR X))
(COND ((NULL (SETQ X (CDR X))))
((ATOM X) (PRINC '/ /./ ) (PRIN1 X))
(T (TYO 32.) (GO A)))
(TYO 41.))))
NIL)
(DEFUN OUTPUT (X)
((LAMBDA (ATP)
(COND ((COND ((AND ATP (NOT (EQ X 'FOO))))
((NOT ATPL) (NOT (EQ (CAR LOUT) 'JRST)))
((NOT (EQ LOUT 'FOO)))
((NOT ATPL1) (NOT (EQ (CAR LOUT1) 'JRST)))
(T))
(COND ((EQ LOUT 'FOO) (SETQ LOUT X ATPL ATP))
(T (COND ((EQ LOUT1 'FOO))
((PROG2 (AND (NOT ATPL1)
(EQ (CAR LOUT1) 'JUMPA)
(SETQ LOUT1 (CONS 'JRST (CDR LOUT1))))
NIL))
(FASLPUSH #(PUSH LOUT1 LAPLL))
(T (COUTPUT GOFOO) (COUTPUT LOUT1) (COUTPUT NULFU)))
(SETQ LOUT1 LOUT ATPL1 ATPL LOUT X ATPL ATP))))))
(ATOM X)))
(DEFUN OUT1 (A B C)
((LAMBDA (Z X ACP N@P TPC)
;;; A MIGHT BE "MOVE" OR "(MOVE)", THE LATTER MEANING MOVE INDIRECT
;;; B IS USUALLY 0 - 17, OR MAYBE "P", OR "T"
;;; C IS N FOR SLOTLOC N
;;; "FOO" FOR SYMBOL FOO
;;; "(SPECIAL FOO)" FOR SPECIAL VARIABLE FOO
;;; "(QUOTE FUN)" FOR DIRECT REFERENCE TO "FUN", AS IN (CALL 1 'FUN)
;;; "((QUOTE THING))" FOR LOADING QUOTIFIED STUFF,
;;; AS IN (MOVEI 1 'THING), OR (PUSH P (% 0 0 'THING))
(SETQ ACP (AND (EQ TPC 'FIXNUM) (PLUSP C)))
(SETQ X
(COND ((OR (MEMQ TPC '(FIXNUM SYMBOL)) #(SYMBOLP (CAR C)))
(COND ((AND N@P ACP #(REGACP C) (SETQ X (GET A 'IMMED)))
(SETQ N@P NIL) X)
(N@P A)
((CAR A))))
(T (SETQ C (CAR C)) ;C WAS "((QUOTE THING))"
(COND ((SETQ X (COND (N@P (GET A 'IMMED)) ((CDR A))))
(SETQ N@P T)
X)
(T (SETQ C (LIST '% 0 0 C))
(COND (N@P A) ((CAR A))))))))
(SETQ Z (COND ((AND ACP (NOT N@P)) (SETQ N@P T) (LIST 0 C))
((AND (NOT ACP) (EQ TPC 'FIXNUM))
(COND (#(NUMPDLP C)
(COND (#(FLPDLP C) (CONS (- C #(FLP0)) '(FLP)))
(T (CONS (- C #(FXP0)) '(FXP)))))
((CONS C '(P)))))
((NCONS C))))
(SETQ Z (CONS B (COND (N@P Z) ((CONS '@ Z)))))
(OUTPUT (CONS X Z)))
NIL NIL NIL (ATOM A) (TYPEP C)))
(DEFUN OUT3 (OP ACX AD) (COND ((REGADP AD) (OUT2 OP ACX AD)) ((OUT1 (CAR OP) ACX AD))))
(DEFUN OUT2 (OP ACX AD)
((LAMBDA (TYPE NEWAD)
(COND ((OR (ATOM OP) (ATOM AD) (ATOM (CAR AD))
(NOT (EQ (CAAR AD) 'QUOTE))
(NOT (MEMQ (SETQ TYPE (TYPEP (SETQ NEWAD (CADAR AD))))
'(FIXNUM FLONUM))))
(OUT1 OP ACX AD))
(T ((LAMBDA (II NEWOP)
(COND ((AND (EQ TYPE 'FIXNUM)
(SETQ NEWOP (GET (CAR OP) 'IMMED))
(COND ((AND (NOT (< (SETQ II NEWAD) 0)) (< II 1←18.)))
((AND (LESSP -1←18. II 0)
(SETQ NEWOP (GET NEWOP 'MINUS)))
(SETQ NEWAD (- II))
T))))
((AND (EQ TYPE 'FLONUM)
(ZEROP (LSH NEWAD 18.))
(SETQ NEWOP (GET (CAR OP) 'FLOATI)))
(SETQ II (LSH NEWAD 0))
(COND ((AND (> II 0)
(MEMQ NEWOP '(FDVRI FMPRI))
(ZEROP (BOOLE 1 (LSH NEWAD 0) 377777777)))
(SETQ II (- (LSH II -27.) 201))
(AND (EQ NEWOP 'FDVRI) (SETQ II (- II)))
(SETQ NEWOP 'FSC))
(T (SETQ II (LSH II -18.))))
(SETQ NEWAD II))
(T (SETQ NEWOP (CAR OP) NEWAD (LIST '% NEWAD))))
#(OUTFS NEWOP ACX NEWAD))
0 NIL))))
NIL NIL))
(DEFUN OUT3FIELDS (Z Y X) (OUTPUT (LIST X Y Z)))
(DEFUN OUT4FIELDS (V Z Y X) (OUTPUT (LIST X Y Z V)))
(DEFUN OUT5FIELDS (W V Z Y X) (OUTPUT (LIST X Y Z V W)))
(DEFUN OUTJ (INST LARG TAG)
(AND (NOT #(ACLOCP LARG)) (BARF LARG |NOT AC - OUTJ|))
(CLEARVARS)
(OUTJ0 INST LARG TAG NIL LARG))
(DEFUN OUTJ0 (INST LARG TAG JSP DONT)
(PROG (TEM SVSLT YAGPV N LARGSLOTP)
(SETQ N 0 LARGSLOTP (NUMBERP LARG))
(AND (NOT JSP) LARGSLOTP (NOT (PLUSP LARG)) (SETQ SVSLT (CONTENTS LARG)))
(AND (RSTD TAG
(COND (#(ACLOCP DONT) DONT) (0))
(COND ((AND LARGSLOTP (PLUSP LARG)) LARG) (0)))
SVSLT
(SETQ LARG #(ILOCF SVSLT)))
(COND ((AND (NOT JSP)
(COND ((NOT LARGSLOTP)
(EQ (CAR LARG) 'SPECIAL))
((AND SVSLT (NULL (CDR SVSLT)))
(OR (VARBP (CAR SVSLT))
(ASSQ (CAR SVSLT) SPLDLST))))
(REGADP LARG)
(SETQ YAGPV (MEMQ NIL REGACS)))
(CONT (SETQ N (- #(NACS+1) (LENGTH YAGPV)))
(CONS (COND (LARGSLOTP (CAR SVSLT)) ((CADR LARG))) 'DUP))))
(COND ((NOT (AND (NOT JSP) #(ACLOCP LARG))) NIL)
(#(REGACP LARG)
(AND (SETQ TEM (ASSQ INST '((JUMPE NIL ((QUOTE NIL)))
(JUMPN ((QUOTE NIL)) NIL))))
(CADDR TEM)
(SETQ SVSLT (CONTENTS LARG))
(RPLACA SLOTX (CAADDR TEM))))
(#(NUMACP LARG) (AND (MEMQ INST '(SOJN SOJE)) (RPLACA SLOTX NIL))))
; SET UP THE ACS OF THE LEVEL OF TAG,
; ASSUM ING THAT THE JUMP IS TAKEN
(AND (SETQ YAGPV (GET TAG 'LEVEL))
(ACMRG (CAR YAGPV) (CADR YAGPV) (CADDR YAGPV) REGACS NUMACS ACSMODE
(COND ((NOT (GET TAG 'USED)) (PUTPROP TAG T 'USED)))))
; JUMP FALLS THROUGH, SO SRESET SLOTLIST ACCORDINGLY
(COND (TEM (FIND LARG)
(COND ((CADR TEM) (RPLACA SLOTX (CAADR TEM)))
(SVSLT (RPLACA SLOTX SVSLT)))))
(SETQ DONT (COND (JSP NIL)
((AND LARGSLOTP (PLUSP LARG))
(COND ((AND #(NUMACP LARG)
(NOT (ATOM INST))
(MEMQ (CAR INST) '(TRNN TRNE TLNN TLNE)))
(OUT1 (GET (CAR INST) 'CONV) LARG (CDR INST))
(SETQ INST 'JUMPA))))
(T (OUT1 (COND ((EQ INST 'JUMPE) 'SKIPN) ('SKIPE)) N LARG)
(SETQ INST 'JUMPA))))
#(OUTFS INST
(COND (DONT 0) (LARG))
(COND ((AND (NOT ATPL) (SETQ TEM (GET TAG 'PREVI)) (EQUAL LOUT TEM))
(SETQ LOUT (SETQ ATPL 'FOO))
(LIST TAG -1))
(TAG)))
(RETURN LARG))) ; RETURN LOC OF ARG
; OUTTAG RETURNS NON-NIL IFF TAG WAS USED
(DEFUN OUTTAG (X)
(COND ((AND X (GET X 'USED))
(CLEANUPSPL NIL)
(CLEARVARS)
((LAMBDA (LL)
(COND (LL (RESTORE LL)
(ACMRG REGACS NUMACS ACSMODE (CAR LL) (CADR LL) (CADDR LL) NIL))
(T (CLEARACS0 T))))
(LEVEL X))
(OUTTAG0 X)
X)))
(DEFUN OUTTAG0 (X)
((LAMBDA (V)
(COND ((AND (AND (NOT ATPL) (NOT ATPL1)) ; JUMPX AC,TG
(MEMQ (CAR LOUT) '(JRST JUMPA))
(EQ X (CADDR LOUT1)) ; JRST 0 TG1
(NOT (EQ (CAR LOUT1) 'JUMPA)) ;TG: . . .
(SETQ V (GET (CAR LOUT1) 'CONV))) ;TURNS INTO JUMP[X'] AC,TG1
(SETQ LOUT (LIST V (CADR LOUT1) (CADDR LOUT)))
(SETQ LOUT1 (SETQ ATPL1 'FOO)))) ;ATPL IS ALREADY NIL
(COND ((NOT ATPL)
(AND (NOT (EQ (CAR LOUT) 'JUMPA))
(OR (EQ (CAR LOUT) 'JRST) ; JUMPX AC,TG
(GET (CAR LOUT) 'CONV)) ;TG: .. .
(EQ X (CADDR LOUT)) ;TURNS INTO JUST TG:
(SETQ LOUT (SETQ ATPL 'FOO))))
((NOT (EQ LOUT 'FOO)) ; JUMPX AC,TG
(AND (NOT ATPL1) ;TG1:
(NOT (EQ (CAR LOUT1) 'JUMPA))
(OR (EQ (CAR LOUT1) 'JRST) ;TG: . . .
(GET (CAR LOUT1) 'CONV)) ;BECOMES MERELY THE TWO TAGS
(EQ X (CADDR LOUT1))
(SETQ LOUT1 (SETQ ATPL1 'FOO)))))
(OUTPUT X))
NIL))
;;; NOTE HOW THE LINES (EQ X (CADDR LOUT1)) AND (EQ X (CADDR LOUT))
;;; PREVENT TAKING CLAUSES LIKE (SKIPN 0 FOO) OR (CAIE AC FOO)
;;; JUMPX AND JUMP[X'] ARE INVERTIBLE CONDITIONS
(DEFUN P2CONSABLE (Z)
((LAMBDA (T2)
(AND (NOT (EQ T2 'QUOTE))
(OR (MEMQ T2 UNSFLST)
(ILOC1 (SETQ T2 (VARBP T2)) Z 'FIXNUM)
(ILOC1 T2 Z 'FLONUM))))
(CAR Z)))
(DEFUN P2NUMCONS (ITEM LOC)
(PROG (FL)
(AND (NULL LOC) (SETQ LOC #(ILOCREG ITEM 1)))
(COND ((NOT (REGADP LOC))
((LAMBDA (TAKENAC1) (SETQ FL (CPUSH 1))) #(NUMVALAC))
(LOCINNUMAC0 ITEM
#(NUMVALAC)
(COND ((OR (NOT (EQ FL 'PUSH))
(NOT (EQ (GETMODE LOC) (GETMODE0 1 NIL T))))
LOC))
'REMOVEB)
(OUTPUT (COND ((EQ (OR (CAR ACSMODE) (GETMODE0 #(NUMVALAC) T T)) 'FIXNUM)
'(JSP T FXCONS))
('(JSP T FLCONS))))
(RPLACA NUMACS NIL) ;(CONT #(NUMVALAC) NIL)
(SETQ FL NIL))
((AND (NUMBERP LOC)
(NOT (AND (= LOC 1)
(NOT ATPL)
(EQ (CAR LOUT) 'JSP)
(MEMQ (CADDR LOUT) '(FXCONS FLCONS))))
(SETQ LOC (CAR (CONTENTS LOC)))
(NOT #(SPECIALP LOC))
(OR (NUMERVARP LOC) (MEMQ LOC UNSFLST)))
(LOADAC ITEM 1 NIL)
(OUTPUT '(JSP T PDLNMK)))
(T (REMOVE ITEM) (SETQ FL T)))
(RETURN (COND (FL ITEM)
((CAR (RPLACA REGACS (LIST (GENSYM)))))))))
;THE RPLACA IS ESSENTIALLY AN QUICK WAY TO DO (CONT 1 MUMBLE)
(DEFUN PROGHACSET (SPFL EXP)
; SPECIAL HAC FOR (LAMBDA (SVAR1) (PROG (SVAR2) :))
; OR FOR (LAMBDA (SVAR1) (COMMENT :) : (PROG (SVAR2) : ))
; TO ALLOW ONLY ONE CALL TO SPECBIND
(COND ((AND SPFL
(COND ((EQ (CAR EXP) 'PROG))
((AND (EQ (CAR EXP) PROGN)
(EQ (CAADR EXP) 'PROG)
(NULL (GCDR (FUNCTION
(LAMBDA (Z)
(NOT (MEMQ (CAAR Z) '(COMMENT DECLARE)))))
(CDDR EXP))))
(SETQ EXP (CADR EXP))
T))
(GCDR (FUNCTION (LAMBDA (Z) #(SPECIALP (CAR Z)))) (CADDR (CDDDR EXP))))
(SETQ SFLG T)
NIL)
(T (SETQ SFLG NIL) SPFL)))
(DEFUN QNILP (X) (AND (EQ (CAR X) 'QUOTE) (NULL (CADR X))))
(DEFUN Q0P (X) (AND (EQ (CAR X) 'QUOTE) (SIGNP E (CADR X))))
(DEFUN Q1P (X) (AND (EQ (CAR X) 'QUOTE)
(SIGNP G (CADR X))
(= (CADR X) 1)))
(DEFUN QNP (X) (AND (EQ (CAR X) 'QUOTE) (NUMBERP (CADR X))))
(DEFUN REGADP (X)
(OR (NOT (NUMBERP X)) ;(SPECIAL A), ((QUOTE 5)), ETC
(NOT (OR #(NUMACP X) #(NUMPDLP X))))) ;NUMWORLD
(DEFUN REMOVEB (X) (OR (NULL X) (REMOVE X) (REMOVS X)))
(DEFUN REMOVE (X) ;REMOVE DOES NOT TAKE CARCDR'INGS OFF THE SPLDLST
(AND X
(SETQ LDLST (DELQ X LDLST))
(COND ((EQ (CAR X) 'QUOTE))
((NUMBERP (CDR X))
(REMOVS X)
T))))
(DEFUN REMOVS (X)
(AND X
SPLDLST
(SETQ X (CLMEMBER (CAR X)
(CDR X)
SPLDLST
(COND ((NUMBERP (CDR X)) '=) ('ASSQ))))
(RPLACA X NIL)))
(DEFUN RESTORE (X)
(AND X
(DO ((MODES '(NIL FIXNUM FLONUM) (CDR MODES)) ;CYCLES THRU PDLS REGPDL FXPDL FLPDL
(RSL)
(XS (CDDDR X) (CDR XS)))
((OR (NULL MODES) (NULL XS)) RSL)
(PROG (RSTNO N PDLTP P X MODE)
(SETQ X (CAR XS) MODE (CAR MODES))
(SETQ P #(PDLAC MODE) PDLTP #(PDLGET MODE))
(AND (MINUSP (SETQ RSTNO (DIFFERENCE (LENGTH PDLTP) (LENGTH X))))
(BARF (LIST X '/
(SLOTLISTCOPY) ) |RESTORE LOSSAGE|))
A1 (AND (ZEROP RSTNO) (RETURN RSL))
(SETQ N 0 RSL T)
A2 (COND ((NOT (OR (NULL PDLTP)
(= N RSTNO)
(DVP1 PDLTP (CONVNUMLOC 0 MODE))))
(SETQ N (ADD1 N))
(SETQ PDLTP (CDR PDLTP))
(COND ((EQ MODE 'FIXNUM) (SETQ FXPDL PDLTP))
((NULL MODE) (SETQ REGPDL PDLTP))
(T (SETQ FLPDL PDLTP)))
(GO A2)))
; SO SUBTRACT OFF AS MUCH AS POSSIBLE AND POP TOP
; PDL SLOT TO SOME SAFE SLOT , FOR SAFE SLOT S TRY FIRST THOSE
; WITH THE SAME ITEM NAME ON THE BACK OF THE PDL, AND THEN THOSE
; OF THE ACS, LAST RESORT TRY FREEAC
(SETQ RSTNO (DIFFERENCE RSTNO N))
; (AND (EQ LOUT 'FOO) (SETQ LOUT LOUT1) (SETQ LOUT1 'FOO))
; ABOVE INSTRUCTION HAD TO BE REMOVED BECAUSE OF JRST FOLLOWED FOO CASE
(AND (NOT ATPL)
(EQ (CAR LOUT) 'SUB) ;THIS CONVERTS TWO RESTORES OF
(EQ (CADR LOUT) P) ;SUB P,[N,,N] - SUB P,[M,,M]
(SETQ N (PLUS N (CADDDR (CADDR LOUT))) ;INTO ONE
LOUT (SETQ ATPL 'FOO))) ;SUB P,[N+M,,N+M]
(AND (NOT ATPL1)
(EQ (CAR LOUT1) 'SUB)
(EQ (CADR LOUT1) P)
(OR (EQ LOUT 'FOO)
(AND (NOT ATPL)
(OR (EQ (CAR LOUT) 'SUB)
(EQ (CAR LOUT) 'PUSHJ)
(AND (EQ (CAR LOUT) 'JSP) (NOT (EQ (CADDR LOUT) 'PDLNMK))))))
(SETQ N (PLUS N (CADDDR (CADDR LOUT1)))
LOUT1 LOUT ATPL1 ATPL LOUT (SETQ ATPL 'FOO)))
(AND (COND ((ZEROP N) NIL)
((AND (NOT ATPL) (EQ (CAR LOUT) 'PUSH))
(AND (EQ (CADR LOUT) P)
(PROG2 (SETQ LOUT (SETQ ATPL 'FOO)) T)))
((AND (AND (NOT ATPL) (NOT ATPL1))
(EQ (CAR LOUT1) 'PUSH)
(EQ (CAR LOUT) 'SUB))
(AND (EQ (CADR LOUT1) P)
(PROG2 (SETQ LOUT1 (SETQ ATPL1 'FOO)) T))))
(SETQ N (1- N)))
(AND (NOT (ZEROP N)) #(OUTFS 'SUB P (LIST '% 0 0 N N)))
(AND (ZEROP RSTNO) (RETURN RSL))
((LAMBDA (N BESTCNT BESTLOC FL TEM)
(COND ((AND (SETQ TEM (VARBP (CAR FL))) (NOT (EQ TEM 'SPECIAL))) ;LOCALVARP
(DO ((L (FIND N) (CDR L)) (V X (CDR V)))
((NULL V))
(COND ((NULL (CAR V)))
((NOT (EQ (CAAR V) (CAAR PDLTP))))
((NULL (CDAR V))
(COND ((AND (EQ (CAAR L) (CAAR V))
(EQ (CDAR L) 'OHOME)))
((NOT (DVP1 L N)))
((NOT (AND (MEMQ (CDAR L) '(NIL OHOME))
(VARBP (CAAR L))))
(SETQ BESTLOC #(FREACB))
(OUT1 'MOVE BESTLOC N)
(CONT BESTLOC (CONTENTS N))
(CONT N NIL))
((BARF N |SOMEONE'S IN MY HOME - RESTORE |)))
(RETURN (SETQ BESTCNT (SETQ BESTLOC N))))
((OR (AND (SETQ FL (NUMBERP (CDAR V)))
(GREATERP (CDAR V) BESTCNT))
(ZEROP BESTCNT))
(SETQ BESTLOC N)
(AND FL (SETQ BESTCNT (CDAR V)))))
(SETQ N (SUB1 N))))
(#(ACLOCP (SETQ FL (ILOC0 FL MODE)))
(SETQ BESTLOC FL BESTCNT 1)))
(SETQ FL (CAR PDLTP))
(COND ((AND (ZEROP BESTCNT)
(NOT ATPL)
(EQ (CAR LOUT) 'PUSH)
#(ACLOCP (SETQ BESTLOC (CADDR LOUT))))
(WARN (LIST BESTLOC N) |PUSHPOP - RESTORE|)
(SETQ LOUT (SETQ ATPL 'FOO))
(SHRINKPDL 1 MODE))
(T (AND (ZEROP BESTCNT)
(SETQ BESTLOC (COND (MODE (FREENUMAC)) (#(FREACB)))))
(CONT BESTLOC FL)
(OPOP BESTLOC MODE))))
(CONVNUMLOC (MINUS RSTNO) MODE) 0 0 (CAR PDLTP) NIL)
(SETQ RSTNO (SUB1 RSTNO))
(SETQ PDLTP (COND ((EQ MODE 'FIXNUM) FXPDL)
((NULL MODE) REGPDL)
(FLPDL)))
(GO A1)))))
(DEFUN RST (X)
; RESTORE SLOTLIST TO LEVEL OF A TAG,
; VALUABLE STUFF SHOULD NOT BE IN ACS
; IF VALUE IS NON NIL, IT MUST BE A SLOTLIST LEVEL
(AND X (RESTORE (LEVEL X))))
(DEFUN RSTD (TAG A1 A2) ;RESTORE, BUT DONT TAKE THE
(DECLARE (FIXNUM A1 A2))
(PROG (SV1 SV2 RSL) ;ACCUMULATORS A1 AND A2 FOR TEMPS
(COND ((ZEROP A1)
(AND (ZEROP A2) (RETURN (RST TAG)))
(SETQ A1 A2 A2 0)))
(AND (= A1 A2) (SETQ A2 0))
(SETQ SV1 (CONTENTS A1))
(RPLACA SLOTX '(NIL . TAKEN))
(COND ((NOT (ZEROP A2))
(SETQ SV2 (CONTENTS A2))
(RPLACA SLOTX '(NIL . TAKEN))))
(SETQ RSL (RST TAG))
(CONT A1 SV1)
(AND (NOT (ZEROP A2)) (CONT A2 SV2))
(RETURN RSL)))
(DEFUN RETURNTAG NIL
((LAMBDA (TAG)
#(OUTFS 'MOVEI 'T TAG)
(OPUSH 'T '(NIL . TAKEN) NIL)
TAG)
(GENSYM)))
(DEFUN SETMODE (AC MODE) (RPLACA #(ACSMODESLOT AC) MODE))
(DEFUN SHOULD-I-P2NUMCONS-P (UNSAFEP VAR SPFL ARG LARG)
;;;VAR WILL NEVER BE LOCAL NUMVAR - CHECKED BY CALLER
(AND (COND (SPFL)
((NULL (SETQ UNSAFEP (UNSAFEP UNSAFEP))) ;POSSIBLY A NUMQUANTITY
(COND ((REGADP LARG) NIL)
((NULL (SETQ LARG (ILOC0 ARG NIL))) T)
((REGADP LARG) NIL)
((OR SPFL (NULL (UNSAFEP VAR))))))
((COND ((ATOM UNSAFEP) (LLTV/.UNSAFE UNSAFEP)) ;CONS FOR X IN (SETQ X Y) IF BOTH ARE
((MEMQ PROGN UNSAFEP)) ;SOME WEIRD SCREW CASE
((DO Y UNSAFEP (CDR Y) (NULL Y) ;LLTVS, AND Y IS UNSAFE
(AND (LLTV/.UNSAFE (CAR Y)) (RETURN T))))))
((NOT (UNSAFEP VAR)))) ;NO CONS FOR LOCAL VAR ALREADY UNSAFE
(CAR #(PUSH (P2NUMCONS ARG LARG) LDLST))))
(DEFUN LLTV/.UNSAFE (X) ;USED ONLY BY SHOULD-I-P2NUMCONS-P
(AND #(SYMBOLP X) ;RETURNS NON-NIL IFF X IS A LOCAL NOTYPE VARIABLE
(NOT #(SPECIALP X)) ; WHICH ALSO HAPPENS TO BE UNSAFE
(NOT (VARMODE X))
(MEMQ X UNSFLST)))
(DEFUN SHRINKPDL (N MODE)
(DO N N (SUB1 N) (ZEROP N)
(COND ((EQ MODE 'FIXNUM) #(POP FXPDL))
((NULL MODE) #(POP REGPDL))
(#(POP FLPDL)))))
(DEFUN SLOTLISTCOPY NIL
(LIST (APPEND REGACS NIL) (APPEND NUMACS NIL) (APPEND ACSMODE NIL)
(APPEND REGPDL NIL) (APPEND FXPDL NIL) (APPEND FLPDL NIL)))
(DEFUN SLOTLISTSET (L)
(SETQ REGACS (CAR L) NUMACS (CADR L) ACSMODE (CAR (SETQ L (CDDR L)))
REGPDL (CADR L) FXPDL (CAR (SETQ L (CDDR L))) FLPDL (CADR L)))
(DEFUN VARBP (X)
((LAMBDA (Y)
(COND ((NULL Y) (COND ((MEMQ X SPECVARS) 'SPECIAL)
((NOT #(SYMBOLP X)) (BARF X |NOT SYMBOL - VARBP|))))
((EQ (CAR Y) 'SPECIAL) 'SPECIAL)
(T)))
(GETL X '(SPECIAL OHOME))))
(DEFUN VARMODE (VAR)
(COND ((CDR (COND ((ASSQ VAR MODELIST)) ('(NIL)))))
((GET VAR 'NUMVAR))))
;;; END OF PHASE2 AUXILLIARY FUNCTIONS
(COMMENT PHASE1 FUNCTIONS)
(DEFUN P1 (X)
(PROG (Z Y TEM MODE)
A (COND ((NULL X) (GO P1NIL))
((EQ X T) (RETURN (COND (ARITHP '('T)) (''T))))
((MEMQ (SETQ Z (TYPEP X)) '(BIGNUM FIXNUM FLONUM))
(SETQ X (LIST 'QUOTE X) MODE (COND ((EQ Z 'BIGNUM) NIL) (Z)))
(GO P1XIT))
((EQ Z 'SYMBOL)
(COND ((SETQ Z (ASSQ X RNL))
(SETQ X (CDR Z))
(GO A)))
(SETQ CNT (ADD1 CNT))
(P1SPECIAL X)
(AND ARITHP (SETQ MODE (VARMODE X)))
(GO P1XIT))
((NOT (EQ Z 'LIST)) (PDERR X |RANDOM PIECE OF DATA|) (GO P1NIL))
((EQ (SETQ Z (TYPEP (CAR X))) 'LIST)
(COND ((EQ (CAAR X) 'LAMBDA) (RETURN (P1LAM (CAR X) (CDR X))))
((EQ (CAAR X) 'LABEL) (RETURN (P1LABEL X)))
((EQ (CAAR X) CARCDR)
(SETQ X (LIST (CAR X) (P1VN (CADR X))))
(GO P1XIT))
((MEMQ (CAAR X) '(QUOTE FUNCTION))
(SETQ X (CONS (CADAR X) (CDR X)))
(GO A))
((EQ (CAAR X) COMP)
(P1SQV PROGN)
(SETQ X ((LAMBDA (EFFS ARITHP KTYPE PNOB)
(RPLACD (CDAR X) (P1 (CDDAR X)))
(COND ((> (LENGTH (CDR X)) #(NACS)) (P1FAKE X))
(T (CONS (CAR X) (MAPCAR 'P1 (CDR X))))))
NIL NIL NIL T))
(SETQ MODE (AND (MEMQ (CADAR X) '(FIXNUM FLONUM)) (CADAR X)))
(GO P1XIT))
(T (P1SQV PROGN)
(SETQ X ((LAMBDA (EFFS ARITHP KTYPE PNOB)
(SETQ Z (P1 (CAR X)) ARITHP NIL)
(AND (CDR Z) (PDERR X |COMPUTED FUNCTION CANT BE NUMERIC|))
(AND (ATOM (CAR Z))
(SYSP (CAR Z))
(SETQ X (CONS (CAR Z) (CDR X)))
(GO A))
(SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CAR Z)))
(MAPCAR 'P1 (CDR X)))))
NIL T NIL T))
(GO P1XIT))))
((OR (NOT (EQ Z 'SYMBOL)) (NULL (CAR X)))
(PDERR X |UNLIKELY CRUFT IN FUNCTIONAL POSITION|)
(GO P1NIL))
((EQ (CAR X) 'T) (WARN X |T IS A POOR CHOICE FOR FUNCTION NAME|)))
B (COND ((EQ (CAR X) 'QUOTE)
(COND ((OR (NULL (CDR X)) (CDDR X)) (GO WNA))
((OR (EQ (CADR X) 'T) (NULL (CADR X))) (SETQ X (CADR X)) (GO A))
((MEMQ (SETQ TEM (TYPEP (CADR X))) '(FIXNUM FLONUM))
(SETQ MODE TEM)))
(GO P1XIT))
((EQ (CAR X) NULFU) (GO D))
((SETQ Z (P1MACROGET X))
(COND ((EQ (SETQ Z (CAR Z)) GOFOO) (PDERR X |INCORRECT DO FORMAT|) (GO P1NIL))
((EQ Z NULFU) (PDERR X |LISP ERROR DURING MACRO EXPANSION|) (GO P1NIL))
(T (SETQ X Z) (GO A)))))
B11(SETQ Z NIL) ;B12 BELOW - (SETQ Z '(SUBR NIL))
B1 (SETQ TEM NIL)
(COND ((COND (Z (SETQ TEM T) T) ;MAYBE Z ALREADY SETUP FROM ELSEWHERE
((NULL (SETQ Z (GETL (CAR X) '(EXPR FEXPR SUBR FSUBR LSUBR *FEXPR *EXPR *LEXPR))))
NIL)
((OR (NOT (MEMQ (CAR Z) '(SUBR FSUBR LSUBR))) (SYSP (CADR Z)))))
(COND ((AND (NOT TEM) ;THIS "TEM" COULD SIGNAL NON-STANDARD ENTRY TO B1
(OR (SETQ TEM (GET (CAR X) 'ARITHP))
(GET (CAR X) 'NUMBERP)))
(AND (NULL TEM) ;THROW NUMERIC STUFF TO P1ARITH, EXCEPT
(EQ (CAR X) 'EQ) ;TRAP OUT "(EQ MUMBLE NIL)"
(COND ((OR (NULL (CADR X)) (QNILP (CADR X)))
(SETQ TEM (CADDR X))
T)
((OR (NULL (CADDR X)) (QNILP (CADDR X)))
(SETQ TEM (CADR X))
T))
(PROG2 (SETQ X (LIST 'NULL TEM)) (GO B12)))
(AND (P1ACK X NIL -1) (GO WNA))
(RETURN (P1ARITH X NIL TEM)))
((EQ (CAR Z) 'FSUBR)
(COND ((EQ (CAR X) 'SETQ) (RETURN (P1SETQ X)))
((EQ (CAR X) 'PROG) (RETURN (P1PROG (CDR X))))
((EQ (CAR X) 'COND) (RETURN (P1COND (CAR X) (CDR X))))
((EQ (CAR X) 'CATCH)
(RETURN (P1FAKE (LIST 'CATCH (CADR X) (LIST 'QUOTE (CADDR X))))))
((EQ (CAR X) 'ERRSET)
(RETURN (P1FAKE (LIST 'ERRSET
(LIST 'NCONS (CADR X))
(COND ((NULL (CDDR X))) ((CADDR X)))))))
((EQ (CAR X) 'THROW)
(SETQ X (LIST 'THROW
(P1VN (CADR X))
(LIST 'QUOTE (CADDR X))))
(GO P1XIT))
((SETQ TEM (ASSQ (CAR X) '((FUNCTION . QUOTE) (*FUNCTION . *FUNCTION))))
(COND ((OR (NULL (CDR X)) (CDDR X)) (GO WNA)))
(SETQ X (LIST (CDR TEM) (P1GFY (CADR X) 'EXPR)))
(GO P1XIT))
((MEMQ (CAR X) '(AND OR))
(COND ((NULL (CDDR X))
(WARN X |THERE ARE NOT TWO OR MORE CLAUSES HERE - DO YOU REALLY WANT THIS?|)
(SETQ X (COND ((CDR X) (CADR X))
((EQ (CAR X) 'AND))))
(GO A))
(EFFS (RETURN (P1COND (CAR X) (CDR X))))
((EQ (CAR X) 'OR) (SETQ TEM (MAPCAR 'NCONS (CDR X))))
(T (SETQ TEM (L2F (CDR X)))
(SETQ TEM (LIST (LIST (COND ((NULL (CDDR TEM)) (CADR TEM))
((CONS 'AND (CDR TEM))))
(CAR TEM))))))
(RETURN (P1COND 'COND TEM)))
((EQ (CAR X) 'GO) (SETQ X (P1GO X)) (GO P1XIT))
((EQ (CAR X) 'SIGNP) (SETQ X (P1SIGNP X)) (GO P1XIT))
((EQ (CAR X) 'STORE)
((LAMBDA (EFFS ARITHP KTYPE PNOB)
(SETQ Z (P1 (CADDR X)))
(SETQ MODE (CDR Z) Z (CAR Z) ARITHP NIL)
(AND KTYPE MODE (NOT (EQ MODE KTYPE)) (P1ARG-WRNTYP X))
(SETQ X (LIST 'STORE (P1 (CADR X)) Z)))
NIL T (CDR (NUMTYP (CADR X) NIL)) NIL)
(GO P1XIT))
((COND ((EQ (CAR X) 'ARRAYCALL)
(AND (NOT ARRAYOPEN)
(SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CADDR X))) (CDDDR X)))
(GO A))
(AND (NULL (CDDDR X)) (GO WNA))
T)
((MEMQ (CAR X) '(SUBRCALL LSUBRCALL))
(P1SQV PROGN)
T))
(COND ((OR (NULL (CDR X)) (NULL (CDDR X))) (GO WNA))
((EQ (SETQ Z (TYPEP (CADR X))) 'SYMBOL))
((AND (EQ Z 'LIST) (NOT (EQ (CADDR X) 'QUOTE))))
(T (PDERR X |WRONG FUNCTIONAL DESIGNATOR|)))
(COND ((SETQ MODE (ASSQ (CADR X) COMAL))
(SETQ MODE (AND (NOT (EQ (CAR MODE) T)) (CAR MODE))))
(T (WARN X |NON-STANDARD TYPE INFO| 3 5) (SETQ MODE NIL)))
(AND (COND ((EQ (SETQ Z (TYPEP (CADDR X))) 'SYMBOL)
(MEMQ (CADDR X) '(T NIL)))
((EQ Z 'LIST)
(MEMQ (CAADDR X) '(QUOTE FUNCTION *FUNCTION)))
(T))
(PDERR X |THE FUNCTION POINTER CANT BE RIGHT|))
((LAMBDA (EFFS ARITHP KTYPE PNOB)
(COND ((EQ (CAR X) 'LSUBRCALL)
(SETQ X (P1FAKE (CONS (CAR X) (CDDR X))))
(RPLACD (SETQ TEM (CADDDR (CDDAR X)))
(CONS MODE (CDR TEM))))
(T (AND (> (LENGTH (CDDDR X)) 5)
(PDERR X |TOO MANY ARGS TO CALL|))
(SETQ ARITHP T Z (P1 (CADDR X)))
(AND (CDR Z) (PDERR X |NUMERIC FUNCTION POINTER ILGL|))
(AND (EQ (CAR X) 'ARRAYCALL) (SETQ KTYPE 'FIXNUM))
(SETQ ARITHP NIL)
(SETQ Z (CONS (CAR Z) (MAPCAR 'P1 (CDDDR X))))
(SETQ X (COND ((EQ (CAR X) 'ARRAYCALL)
(CONS (CAR X) (CONS MODE Z)))
((RPLACA Z (CONS COMP
(CONS MODE (CAR Z))))))))))
NIL NIL NIL T)
(GO P1XIT))
((EQ (CAR X) 'ARRAY)
(SETQ X (CONS '*ARRAY
(CONS (LIST 'QUOTE (CADR X))
(CONS (LIST 'QUOTE (CADDR X)) (CDDDR X)))))
(SETQ Z '(LSUBR NIL))
(GO B1))
((OR (AND (SETQ TEM NIOP/|) (EQ (CAR X) 'IOC)) (EQ (CAR X) 'IOG))
(AND NIOP/| (WARN X |IOC AND IOG ARE FLUSHED IN NEWIO - YOU WILL LOSE|))
(P1SQV PROGN)
(AND (OR (NULL (CDR X)) (NULL (CDDR X))) (GO WNA))
(AND (EQ (CAR X) 'IOG)
(SETQ X (CONS (CAR X)
(CONS (CADR X)
(P1L (CDDR X) EFFS NIL KTYPE)))))
(GO P1XIT))
((EQ (CAR X) 'DECLARE)
(PDERR X |LOCAL DECLARATION AT WRONG PLACE|)
(RETURN X))
((EQ (CAR X) 'ERR)
(SETQ X (COND ((NULL (CDR X)) '(ERR 'NIL))
((OR (NULL (CDDR X))
(AND (CADDR X) (NOT (QNILP (CADDR X)))))
(LIST 'ERR (P1VN (CADR X))))
(X)))
(GO P1XIT))
((EQ (CAR X) 'BREAK)
(AND (OR (NULL (CDR X)) (CDDDR X)) (GO WNA))
(SETQ X (LIST '*BREAK
(COND ((CDDR X) (CADDR X))
('(QUOTE T)))
(LIST 'QUOTE (CADR X))))
(P1SQV PROGN)
(GO B12))
((MEMQ (CAR X) '(STATUS SSTATUS))
(COND ((ZEROP (GETCHARN (CADR X) 6)) (SETQ TEM NIL))
((SETQ TEM (EXPLODEN (CADR X)))
(AND (CDDDDR TEM)
(RPLACD (CDDDDR TEM) NIL))))
(AND (NOT (MEMQ ((LAMBDA (OBARRAY)
(SETQ Y (COND (TEM (IMPLODE TEM))
((INTERN (CADR X))))))
SOBARRAY)
(COND ((EQ (CAR X) 'STATUS) (CAR STSL))
((CADR STSL)))))
(COND ((GET 'INCLUDE '*FEXPR)
(OR NIOP/| (NOT (MEMQ Y '(TTYTY FILEM TTYCO
TTYSC TTYIN TTYSI MAR)))))
(T (OR (NOT NIOP/|) (NOT (MEMQ Y '(PAGEP INTER FREE IOC))))))
(WARN X |POSSIBLY ILGL STATUS CALL| 3 5))
(COND ((AND (SETQ TEM (CDDR X))
(SETQ Z (GET Y 'STATUS))
(SETQ Z (COND ((EQ (CAR X) 'STATUS) (CAR Z))
((CDR Z))))
;NO NEED FOR SPECIAL HANDLING ON ENTRIES LIKE
;CRFILE, CRUNIT, ETC.
(COND ((AND (EQ Z 'A)
(OR (P1VAL (CAR TEM) NIL)
(AND (CDR TEM) (P1VAL (CADR TEM) NIL))))
(SETQ TEM (MAPCAR 'P1QLIFY TEM))
T)
;LIKE ([S]STATUS FOO VALUE1)
;OR ([S]STATUS FOO VALUE1 VALUE2)
((AND (EQ Z 'B)
(OR (P1VAL (CAR TEM) T) (P1VAL (CADR TEM) NIL)))
(SETQ TEM (CONS (COND (#(SYMBOLP (CAR TEM))
(LIST 'QUOTE (CAR TEM)))
(T (P1VN (CAR TEM))))
(AND (CDR TEM)
(CONS (P1QLIFY (CADR TEM))
(AND (CDDR TEM)
(LIST (LIST 'QUOTE
(CADDR TEM))))))))
T)))
;LIKE (SSTATUS MACRO D VALUE1)
(SETQ Z (CONS 'CONS (CONS (LIST 'QUOTE (CADR X)) (LIST (P1CONS TEM))))))
(T (SETQ Z (LIST 'QUOTE (CDR X)))))
(SETQ X (CONS (CONS 'FSUBR (CAR X)) Z))
(GO P1XIT))
((EQ (CAR X) 'PROGV)
(AND (NULL (CDDDR X)) (GO WNA))
(RETURN (P1PROGN (CDR X) 'PROGV)))
(T (AND (NOT (GET X 'ACS)) (P1SQV PROGN))
(RETURN (P1MODESET X)))))
((EQ (CAR Z) 'LSUBR)
(COND ((EQ (CAR X) 'LIST)
(SETQ X (COND ((NULL (CDR X)) NIL) ((P1CONS (CDR X)))))
(COND (ARITHP (RETURN (NCONS (P1VN X))))
(T (GO B12)))))
(AND (P1ACK X 'LSUBR -1) (GO WNA))
(AND (EQ (GET (CAR X) 'NOTNUMP) 'EFFS) (P1SQV NULFU))
(COND ((EQ (CAR X) 'PROG2)
(RETURN (P1PROG2 (CDR X))))
((EQ (CAR X) 'PROGN) (RETURN (P1PROGN (COND ((CDR X)) ('(NIL))) PROGN)))
((COND ((AND (NULL (CDR X))
(EQ (CAR X) 'TERPRI)
(SETQ Z '(TERPRI . *TERPRI))))
((AND (CDR X) (NULL (CDDR X))
(SETQ Z (ASSQ (CAR X) '((PRINT . *PRINT)
(PRIN1 . *PRIN1)
(PRINC . *PRINC)
(TYO . *TYO))))))
((AND (CDR X) (CDDR X) (NULL (CDDDR X))
(OR (SETQ Z (ASSQ (CAR X) '((APPEND . *APPEND)
(NCONC . *NCONC)
(DELETE . *DELETE)
(DELQ . *DELQ))))
(AND (NOT CLOSED)
(SETQ Z (ASSQ (CAR X) '((GREATERP . *GREAT)
(LESSP . *LESS)
(PLUS . *PLUS)
(DIFFERENCE . *DIF)
(TIMES . *TIMES)
(QUOTIENT . *QUO)))))))))
(SETQ X (CONS (CDR Z) (CDR X))))
((SETQ Z (ASSQ (CAR X) '((MAPCAN (*MAP 0) MAPCON CAR)
(MAPCON (*MAP 1) MAPCON LIST)
(MAPC (*MAP 2) MAP CAR)
(MAP (*MAP 3) MAP LIST)
(MAPCAR (*MAP 4) MAPLIST CAR)
(MAPLIST (*MAP 5) MAPLIST LIST)
(MAPATOMS))))
(RETURN (P1MAP (CDR X) Z)))
((EQ (CAR X) 'FUNCALL)
(COND ((NULL (CDR X)) (GO WNA))
((AND (NOT (ATOM (SETQ Z (CADR X))))
(SETQ Z (P1FUNGET (CADR X))))
(SETQ X (COND ((AND (ATOM (CADR Z))
(OR (GET ('CADR Z) '*FEXPR)
(EQ (SYSP (CADR Z)) 'FSUBR)))
(CONS 'APPLY (CDR X)))
(T (CONS (CADR Z) (CDDR X))))))
(T (SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CADR X))) (CDDR X)))))
(GO A))
((AND (EQ (CAR X) 'BOOLE)
(OR (NUMBERP (CADR X))
(EQ (CAADR X) 'QUOTE))))
;DONT NEED TO P1FAKE EXPLICIT BOOLE SINCE WILL BE OPEN CODED
((EQ (CAR X) '*ARRAY)
(COND ((AND (NOT (ATOM (CADR X))) (EQ (CAADR X) 'QUOTE))
(AND (COND ((NOT #(SYMBOLP (SETQ Z (CADADR X)))))
((AND (GET Z '*ARRAY)
(SETQ Z (GET Z 'NUMFUN)))
(SETQ Y (COND ((MEMQ (CADDR X) '(T NIL)) (CADDR X))
((AND (P1EQQTE (CADDR X))
(MEMQ (CADR (CADDR X))
'(T NIL FIXNUM FLONUM OBARRAY)))
(CADR (CADDR X)))))
(COND ((MEMQ Y '(FIXNUM FLONUM)) (NOT (EQ Y (CADR Z))))
((MEMQ (CADR Z) '(FIXNUM FLONUM))))))
(PDERR X |CONTRADICTS DECLARED TYPE OF ARRAY|))))
(P1SQV NULFU)
(RETURN (P1FAKE X)))
((AND (EQ (CAR X) 'APPLY)
(NULL (CDDDR X))
(RETURN (PWTNTPTFN (CDR X)))))
((AND (EQ (CAR X) 'EVAL) (NULL (CDDR X)))
(P1SQV PROGN)
(SETQ Z (LIST (P1VN (CADR X))))
(COND ((AND (NOT (ATOM (CAR Z))) ;SPECIAL HAC FOR
(EQ (CAAR Z) 'CONS) ;(EVAL (CONS 'FSUBR L))
(SETQ X (P1F (CADAR Z) (CADDAR Z)))))
(T (SETQ X (CONS '*EVAL Z))))
(GO P1XIT))
(T (COND ((GET (CAR X) 'ACS)
(AND (EQ (GET (CAR X) 'NOTNUMP) 'EFFS) (P1SQV NULFU)))
(T (P1SQV PROGN)))
(RETURN (P1FAKE X)))))
((EQ (CAR Z) 'SUBR)
(AND (GET (CAR X) 'CARCDR) (RETURN (P1CARCDR X)))
(AND (P1ACK X 'SUBR -1) (GO WNA))
(AND (EQ (CAR X) 'NOT) (SETQ X (CONS 'NULL (CDR X))))
(SETQ Y T)
(COND ((EQ (CAR X) 'NULL)
(AND (NUMTYPEP (CADR X) NIL)
(WARN X |ATTEMPT TO APPLY NULL TO A NUMBER QUANTITY| 3 5))
(SETQ X ((LAMBDA (EFFS ARITHP KTYPE)
(COND ((AND (P1BOOL1ABLE (CADR X))
(OR EFFS (NOT (EQ (CAADR X) 'MEMQ))))
(COND (EFFS (LIST 'NULL (P1 (CADR X))))
(T (P1COND 'COND (LIST (LIST X T))))))
(T (SETQ EFFS NIL) (LIST 'NULL (P1 (CADR X))))))
EFFS NIL NIL))
(GO P1XIT))
((EQ (CAR X) 'RETURN) (RETURN (P1RETURN X)))
((NOT (GET (CAR X) 'ACS))
(COND ((EQ (CAR X) 'BOUNDP)
(SETQ X (LIST 'NOT
(CONS 'EQ (CONS (LIST 'SYMEVAL (CADR X))
QSM))))
(GO B11))
((MEMQ (CAR X) '(ROT LSH FSC))
(SETQ MODE (COND ((EQ (CAR X) 'FSC) 'FLONUM)
('FIXNUM)))
((LAMBDA (KTYPE ARITHP EFFS)
(SETQ X (LIST (CAR X)
(P1 (CADR X))
(PROG2 (SETQ KTYPE 'FIXNUM)
(P1 (CADDR X))))))
(COND ((CDR (NUMTYP (CADR X) T)))
(MODE))
NIL
NIL)
(AND (EQ (CAADR Z) 'QUOTE) (NOT (NUMBERP (CADADR Z)))
(PDERR X |INVALID 2ND ARG - MUST BE NUMERIC|))
(GO P1XIT))
((GET (CAR X) 'P1BOOL1ABLE)
(AND (MEMQ (CAR X) '(NUMBERP FIXP FLOATP))
(SETQ TEM (NUMTYPEP (CADR X) NIL))
(COND ((EQ (CAR X) 'FIXP) (EQ (CDR TEM) 'FIXNUM))
((EQ (CAR X) 'FLOATP) (EQ (CDR TEM) 'FLONUM))
((EQ (CAR X) 'NUMBERP) (CDR TEM)))
(PROG2 (WARN X |NUMERIC PREDICATE APPLIED /
TO NUMERIC TYPE DATUM IS A CONSTANT| 4 5)
(SETQ X (LIST 'PROG2 (CADR X) TEM))
(GO B11))))
((EQ (CAR X) 'SET)
(AND (NOT (ATOM (CADR X)))
(EQ (CAADR X) 'QUOTE)
(ATOM (CADADR X))
(RETURN (P1 (APPEND (LIST 'SETQ (CADADR X)) (CDDR X))))))
((MEMQ (CAR X) '(CXR RPLACX))
(AND (COND ((ATOM (SETQ TEM (CADR X))))
((QNP TEM) (SETQ TEM (CADR TEM)) T))
(FIXP TEM)
(COND ((= TEM 0) (SETQ TEM '(CDR . RPLACD)) T)
((= TEM 1) (SETQ TEM '(CAR . RPLACA)) T))
(SETQ X (CONS (COND ((EQ (CAR X) 'CXR) (CAR TEM))
((CDR TEM)))
(CDDR X)))
(GO B11)))
((EQ (CAR X) 'SYMEVAL)
(RETURN (P1CARCDR (CONS 'CDDAR (CDR X)))))
((MEMQ (CAR X) '(SORT SORTCAR))
(REMPROP (CAR X) '*EXPR) ;PROPERTY LIST RE-ORDERING
(*EXPR SORT SORTCAR)
(GO B11))
(T (P1SQV PROGN))))
((MEMQ (CAR X) '(MEMBER ASSOC SASSOC EQUAL MEMQ))
(RETURN (P1LST X)))
((EQ (CAR X) 'MAKNUM)
(AND (CDR (SETQ TEM (P1VAP (CADR X) T)))
(WARN X |MAKNUM ON NUMERIC QUANTITY?| 4 5))
(SETQ X (LIST '(MAKNUM) (CAR TEM)) MODE 'FIXNUM)
(GO P1XIT))
((EQ (CAR X) '*FUNCTION)
(SETQ TEM (LIST (P1VN (CADR X))))
(OR (ATOM (CADR X))
(NOT (EQ (CAADR X) 'QUOTE))
(RPLACA TEM (P1GFY (CADAR TEM) 'EXPR)))
(SETQ X (CONS (CAR X) TEM))
(GO P1XIT))
((EQ (GET (CAR X) 'NOTNUMP) 'EFFS) (P1SQV NULFU))))
(T (P1SQV PROGN)
(COND ((MEMQ (CAR Z) '(FEXPR *FEXPR)) (RETURN (P1MODESET X)))
((MEMQ (CAR Z) '(EXPR *EXPR))
((LAMBDA (N) (COND ((P1ACK X 'SUBR N) (GO WNA))
((MEMQ (CAR X) '(SORT SORTCAR))
(AND (SETQ Y (P1FUNGET (CADDR X)))
(SETQ X (LIST (CAR X) (CADR X) Y))))
((OR (> N #(NACS)) (GET (CAR X) '*LEXPR))
(LREMPROP (CAR X) '(*EXPR *LEXPR))
(PUTPROP (CAR X) T '*LEXPR)
(RETURN (P1FAKE X)))))
(LENGTH (CDR X))))
((EQ (CAR Z) '*LEXPR) (RETURN (P1FAKE X)))
(T (BARF X |LOST-FUNCTION - P1|))))))
((GET (CAR X) '*ARRAY))
((EQ (CAR X) GOFOO) (GO P1XIT))
((SETQ Y (ASSQ (CAR X) RNL))
(SETQ X (CONS (CDR Y) (CDR X)))
(GO B))
(T (P1SQV PROGN)
(COND ((AND Z (SETQ Z (GETL (CAR X) '(*EXPR *FEXPR *LEXPR))))
(REMPROP (CAR X) (CAR Z))
(PUTPROP (CAR X) T (CAR Z))
(GO B11))
((AND (NULL NFUNVARS)
(OR (SETQ TEM #(SPECIALP (CAR X))) (MEMQ (CAR X) BVARS)))
(COND ((NOT (SETQ Y (ASSQ (CAR X) FFVL)))
(COND (TEM #(WARN (CAR X) |USED AS FREE FUNCTIONAL VARIABLE|))
(T (CKCFV (CAR X))
#(WARN (CAR X) |USED AS BOUND FUNCTIONAL VARIABLE|)))
#(PUSH (LIST (CAR X) TOPFN) FFVL))
((NOT (MEMQ TOPFN (CDR Y)))
(RPLACD Y (CONS TOPFN (CDR Y)))))
(SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CAR X))) (CDR X)))
(GO A))
(T #(PUSH (CAR X) UNDFUNS)
(COND ((> (LENGTH (CDR X)) #(NACS))
(PUTPROP (CAR X) T '*LEXPR)
(RETURN (P1FAKE X))))
(AND (NOT (SYSP (CAR X))) (CKARGS (CAR X) (LENGTH (CDR X))))
(PUTPROP (CAR X) T '*EXPR)))))
D ((LAMBDA (PNOB EFFS ARITHP KTYPE MAPP)
(COND ((AND (SETQ TEM (GET (CAR X) 'NUMFUN)) (CDDR TEM))
(SETQ MODE (CADR TEM) TEM (CDDR TEM)
Z NIL ARITHP T)
(SETQ Z (MAPCAR
'(LAMBDA (ITEM)
(SETQ MAPP (COND ((ATOM ITEM) NIL)
((MEMQ (CAR ITEM)
'(MAP MAPC MAPLIST MAPCAR
MAPCAN MAPCON MAPATOMS)))))
(SETQ KTYPE (CAR TEM) TEM (CDR TEM))
(SETQ ITEM (P1 ITEM)) ;TEM IS LIST OF DECLARED ARG TYPES
(COND (Z ITEM) ;Z IS FLAG TO INDICATE MIS-MATCH
((COND ((NULL KTYPE) NIL)
((CDR ITEM) (NOT (EQ KTYPE (CDR ITEM))))
(MAPP)
((NOTNUMP (CAR ITEM))))
(P1ARG-WRNTYP X)
(SETQ Z T ARITHP NIL)
(CAR ITEM))
((CAR ITEM))))
(CDR X)))
(SETQ X (CONS (CAR X) Z))
(GO P1XIT))
(T (AND (EQ (CAR Z) 'SUBR) (NULL Y) (SETQ PNOB NIL))
(SETQ Z NIL)
(DO Y (CDR X) (CDR Y) (NULL Y) #(PUSH (P1 (CAR Y)) Z))
(SETQ Z (NREVERSE Z)))))
T NIL NIL NIL NIL)
C (RETURN (P1MODESET (CONS (CAR X) Z)))
B12 (SETQ Z '(SUBR NIL))
(GO B1)
WNA #(PDERR X |WRONG NUMBER OF ARGS|)
P1NIL (RETURN (COND (ARITHP '('NIL)) (''NIL)))
P1XIT (RETURN (COND (ARITHP (CONS X MODE)) (X))) ))
(DEFUN PWTNTPTFN (X) ;PAGE WIDTH TOO NARROW TO PRINT THIS FUNCTION'S NAME
((LAMBDA (LL TEM VAR FL)
(COND ((AND TEM (SETQ TEM (CADR TEM)) ;FIND FORM LIKE
(OR (AND (NOT (SETQ FL (ATOM TEM))) ;(APPLY (FUNCTION (LAMBDA (A B) FOO)) BAR)
(EQ (CAR TEM) 'LAMBDA)
(OR (NULL (SETQ LL (CADR TEM)))
(NOT (ATOM LL)))
(PROG2 (SETQ LL (LENGTH LL)) T)) ;TEM GETS FUNCTION FORM
(AND FL
(EQ (SYSP TEM) 'SUBR)
(SETQ LL (ARGS TEM)) ;LL GETS NUMBER OF ARGS TO FUNCTION
(PROG2 (SETQ LL (CDR LL)) T))))
(COND ((AND (NOT (ATOM (SETQ VAR (CADR X)))) ;2 OR MORE LAMBDA VARS
(> LL 1) ;IN SOME COMPLEXLY-COMPUTED LIST
(NOT (EQ (CAR VAR) 'QUOTE)))
(SETQ VAR (GENSYM) FL T))
(T (SETQ FL NIL)))
(DO ((Y VAR (LIST 'CDDDDR Y)) (Z))
((NOT (> LL 0)) (SETQ TEM (CONS TEM (NREVERSE Z))))
(DO ((N (COND ((> LL 4) 4) (LL)) (1- N))
(FUN '(CAR CADR CADDR CADDDR) (CDR FUN)))
((NOT (> N 0)))
(SETQ LL (1- LL))
#(PUSH (LIST (CAR FUN) Y) Z)))
(AND FL (SETQ TEM (LIST (LIST 'LAMBDA (LIST VAR) TEM) (CADR X))))
(P1 TEM))
(T (P1SQV PROGN)
(SETQ TEM (MAPCAR 'P1VN X))
(SETQ TEM (COND ((P1F (CAR TEM) (CADR TEM)))
((CONS '*APPLY TEM))))
(COND (ARITHP (NCONS TEM)) (TEM)))))
NIL (P1FUNGET (CAR X)) NIL NIL))
(DEFUN P1ACK (X TYPE NN) ;P1 ARGS CHECK
((LAMBDA (ARGS)
(COND ((NULL ARGS) NIL)
(T (AND (MINUSP NN) (SETQ NN (LENGTH (CDR X))))
(AND (NULL TYPE) (SETQ TYPE (CAR (GETL (CAR X) '(SUBR LSUBR)))))
(COND ((NULL (CAR ARGS))
(OR (NOT (EQ TYPE 'SUBR)) (NOT (= (CDR ARGS) NN))))
((OR (NOT (EQ TYPE 'LSUBR)) (< NN (CAR ARGS)) (> NN (CDR ARGS))))))))
(ARGS (CAR X))))
(DEFUN P1ARG-WRNTYP (X)
#(PDERR (LIST X 'NOT-OF-TYPE KTYPE)
|FIRST ITEM IN LIST IS AN ARGUMENT SOMEWHERE, BUT IS OF THE WRONG TYPE|))
(DEFUN P1ARITH (XPR TEM ARITHFUNP)
(PROG (TYP TEMP FUN SAVXPR KNOW-ALL-TYPES P1LSQ LMBP CONDP P1LL PNOB)
(SETQ FUN (CAR XPR) LMBP T SAVXPR XPR)
(AND (SETQ TEM (ASSQ FUN '((*PLUS . PLUS) (*TIMES . TIMES)
(*DIF . DIFFERENCE) (*QUO . QUOTIENT)
(*LESS . LESSP) (*GREAT . GREATERP))))
(SETQ FUN (CDR TEM)))
(COND ((COND ((MEMQ FUN '(PLUS DIFFERENCE *DIF - -$)) (SETQ TEMP '('0 . '0.0)) NIL)
((MEMQ FUN '(TIMES QUOTIENT *QUO // //$)) (SETQ TEMP '('1 . '1.0)) NIL)
(T)))
((NULL (CDR XPR))
(SETQ XPR (P1 (COND ((MEMQ FUN '(//$ /-$)) (CDR TEMP)) ((CAR TEMP)))))
(SETQ TEM P1LSQ)
(RETURN NIL))
((NULL (CDDR XPR))
(COND ((MEMQ FUN '(//$ -$))
(SETQ XPR (CONS FUN (CONS (CDR TEMP) (CDR XPR)))))
((MEMQ FUN '(// -)) (SETQ XPR (CONS FUN (CONS (CAR TEMP) (CDR XPR)))))
(T (SETQ XPR (P1 (CADR XPR)) TEM P1LSQ) (RETURN NIL)))))
(COND ((SETQ TEMP (COND ((AND ARITHFUNP (CADR ARITHFUNP)) ARITHFUNP)
((MEMQ FUN '(EQ EQUAL)) NIL)
((AND (NOT ARITHFUNP) CLOSED) NIL)
((OR FLOSW FIXSW)
(CONS (COND ((NULL ARITHFUNP) FUN) ((CAR ARITHFUNP)))
(COND (FIXSW '(FIXNUM)) ('(FLONUM)))))))
(SETQ XPR ((LAMBDA (ARITHP EFFS KTYPE) (MAPCAR 'P1 (CDR XPR)))
NIL NIL (SETQ TYP (CADR TEMP))))
(AND (SETQ TEM (P1AEVAL FUN TYP XPR SAVXPR)) (GO XITEM))
(SETQ FUN (CAR (SETQ XPR (APPEND TEMP XPR)))
TYP (CADR (COND (ARITHFUNP) (TEMP)))
KNOW-ALL-TYPES T)
(AND (EQ FUN 'DIFFERENCE)
(Q0P (CAR (SETQ TEMP (CDDR XPR))))
(NULL (CDDR TEMP))
(SETQ XPR (CONS 'MINUS (CONS TYP (CDR TEMP)))))
(GO XITF)))
(COND ((AND (NULL (CDDDR XPR))
(COND ((COND ((EQ FUN 'TIMES) (AND (FLOATP (CADR XPR)) (= (CADR XPR) 1.0)))
((EQ FUN 'PLUS) (AND (FLOATP (CADR XPR)) (ZEROP (CADR XPR)))))
(SETQ FUN (CADDR XPR))
T)
((COND ((MEMQ FUN '(TIMES QUOTIENT))
(AND (FLOATP (CADDR XPR)) (= (CADDR XPR) 1.0)))
((MEMQ FUN '(PLUS DIFFERENCE))
(AND (FLOATP (CADDR XPR)) (ZEROP (CADDR XPR)))))
(SETQ FUN (CADR XPR))
T)))
(RPLACD XPR (LIST FUN))
(RPLACA XPR (SETQ FUN 'FLOAT))))
(AND (GET FUN 'LSUBR) (SETQ PNOB T))
((LAMBDA (ARITHP EFFS KTYPE)
(COND ((AND ARITHFUNP (NULL (CADR ARITHFUNP))) ;SEEK SPECIAL ACTION ON =, >, <
(SETQ KTYPE (CDR (NUMTYP (CADR XPR) T))
TYP (CDR (NUMTYP (CADDR XPR) T)))
(COND ((AND (NULL KTYPE) (NULL TYP)) ;SIGH! NO INFO
((LAMBDA (P1CNT LL LLL ARG1 ARG2 T1 T2) ;FROM NUMTYPEP!
(SETQ ARG1 (P1 (CADR XPR)) T1 (CDR ARG1))
(COND (T1 (SETQ KTYPE T1 ARG2 (P1 (CADDR XPR))))
(T (SETQ ARG2 (P1 (CADDR XPR)) T2 (CDR ARG2))
(SETQ KTYPE (COND (T2) ('FIXNUM)))
(SETQ CNT P1CNT LOCVARS LL)
(MAPC 'RPLACD LOCVARS LLL)
(SETQ ARG1 (P1 (CADR XPR))
ARG2 (P1 (CADDR XPR)))))
(SETQ TYP KTYPE
XPR (LIST (CAR ARG1) (CAR ARG2))))
CNT LOCVARS (MAPCAR 'CDR LOCVARS) NIL NIL NIL NIL)
(GO A))
((AND TYP KTYPE (EQ TYP KTYPE))
(AND (SETQ TEM (P1AEVAL FUN TYP (CDR XPR) SAVXPR))
(GO XITEM)))
(T (SETQ KTYPE (COND ((NULL KTYPE) TYP) ;KTYPE IS SET TO NIL
((NULL TYP) KTYPE) ;ONLY IF A CONFLICT IS FOUND
((EQ KTYPE TYP) KTYPE)))))))
(SETQ TYP NIL)
(SETQ XPR (MAPCAR
'(LAMBDA (X)
(SETQ X (P1 X))
#(PUSH (OR (CDR X) KTYPE) TYP)
(CAR X))
(CDR XPR))))
T NIL NIL)
(COND ((MEMQ (SETQ TYP (SAMETYPES TYP)) '(NIL FIXNUM FLONUM)))
((SETQ TYP (NREVERSE TYP))))
A (SETQ XPR (CONS FUN (CONS TYP XPR)))
(COND ((AND (MEMQ TYP '(FIXNUM FLONUM)) (MEMQ FUN '(IFIX FIX FLOAT)))
(AND (COND ((EQ TYP 'FIXNUM) (MEMQ FUN '(FIX IFIX))) ;CATCHES SUPERFLUOUS FIX OR FLOAT
((EQ TYP 'FLONUM) (EQ FUN 'FLOAT)))
(SETQ XPR (CADDR XPR))
(GO XITF))
(AND (SETQ TEM (P1AEVAL FUN NIL (CDDR XPR) SAVXPR)) (GO XITEM)))
((AND ARITHFUNP (NULL (CADR ARITHFUNP))) ;CATCHES =,<,>
(AND (NOT (MEMQ TYP '(FIXNUM FLONUM)))
#(PDERR SAVXPR |MIXED MODES|))
(RPLACA XPR (CAR ARITHFUNP))
(RPLACA (CDR XPR) TYP)
(SETQ TYP NIL) ;RESULTANT OF PREDICATE IS NOTYPE
(GO XITF)))
(SETQ KNOW-ALL-TYPES #(KNOW-ALL-TYPES TYP))
(COND ((EQ FUN 'EQUAL)
(COND ((AND KNOW-ALL-TYPES (NOT (ATOM TYP)))
(WARN SAVXPR |EQUAL OF A FIXNUM AND A FLONUM IS ALWAYS NIL| 4 5))
((AND (NOT KNOW-ALL-TYPES) TYP) (RPLACA (CDR XPR) NIL))
((OR (P1EQQTE (CADDR XPR)) (P1EQQTE (CADDDR XPR)))
(RPLACA XPR 'EQ)
(RPLACA (CDR XPR) (SETQ TYP NIL))))
(GO XIT))
((EQ FUN 'EQ)
(COND (TYP (WARN SAVXPR |EQ OF A NUMBER - EQUAL ASSUMED| 4 5)
(RPLACA XPR 'EQUAL)))
(GO XIT))
((COND ((EQ FUN 'REMAINDER)
(COND ((EQ TYP 'FIXNUM) NIL)
(T (SETQ KNOW-ALL-TYPES NIL TYP NIL)
(RPLACA (CDR XPR) NIL)
(NOT MUZZLED))))
((AND (NOT KNOW-ALL-TYPES) (NOT MUZZLED) (NOT CLOSED)
(NOT (MEMQ FUN '(FLOAT IFIX))))))
#(WARN SAVXPR |CLOSED COMPILATION FORCED| 4 5)))
(AND (NOT KNOW-ALL-TYPES) ;CONVERT (PLUS A B)
(CDDDR XPR) ;INTO (*PLUS A B)
(NULL (CDDDDR XPR)) ;IF NOT OPEN-CODED
(SETQ TEMP (ASSOCR (CAR XPR) '((*PLUS . PLUS) (*TIMES . TIMES)
(*DIF . DIFFERENCE) (*QUO . QUOTIENT)
(*LESS . LESSP) (*GREAT . GREATERP))))
(SETQ XPR (CONS (CAAR TEMP) (CDR XPR))))
(COND ((AND (NOT KNOW-ALL-TYPES) (GET (CAR XPR) 'LSUBR))
(SETQ XPR (P1GLM1 NIL
XPR
0
(COND ((MEMQ 'FLONUM TYP) 'FLONUM) ;CONTAGIOUS FLOATING
(KTYPE))
NIL))
(SETQ CNT (1+ CNT))
(SETQ TYP (AND ARITHP (PROG2 NIL (CDR XPR) (SETQ XPR (CAR XPR)))))
(SETQ XPR (LIST XPR))
(GO XITF)))
(COND ((EQ FUN 'FLOAT)
(SETQ TYP 'FLONUM)
(GO XITF))
((MEMQ FUN '(FIX IFIX))
(SETQ TYP (COND ((EQ KTYPE 'FLONUM) (P1ARG-WRNTYP SAVXPR) NIL)
((OR (EQ KTYPE 'FIXNUM) FIXSW)
(RPLACA XPR (SETQ FUN 'IFIX))
'FIXNUM)
((EQ FUN 'IFIX) 'FIXNUM)))
(GO XITF)))
(AND KNOW-ALL-TYPES
(SETQ TEM (P1AEVAL FUN (AND (ATOM TYP) TYP) (CDDR XPR) SAVXPR))
(GO XITEM))
(COND ((AND (EQ FUN 'DIFFERENCE) ;CONVERT (- 0 X) OR (DIFFERENCE 0 X)
TYP ;INTO APPROPRIATE VERSION OF "MINUS"
KNOW-ALL-TYPES
(Q0P (CADDR XPR))
(NULL (CDDDDR XPR))
(MEMQ TYP '(FIXNUM FLONUM)))
(SETQ XPR (CONS 'MINUS (CONS TYP (CDDDR XPR))))
(GO XITF)))
XIT (SETQ TYP (COND ((EQ FUN 'HAULONG) 'FIXNUM)
((EQ (SETQ TEMP (GET FUN 'NUMBERP)) 'NOTYPE)
(AND (NULL EFFS) KTYPE (P1ARG-WRNTYP SAVXPR))
NIL)
(CLOSED (RPLACA (CDR XPR) NIL) NIL) ;ALL ARITHP TYPES TAKEN EARLIER
((ATOM TYP) (OR TYP KTYPE)) ;ONLY NUMBERP TYPES COME HERE
((MEMQ 'FLONUM TYP) 'FLONUM)
((AND (MEMQ 'FIXNUM TYP)
(OR (EQ FUN 'REMAINDER)
(AND (EQ FUN 'GCD) (CAR TYP) (CADR TYP))))
'FIXNUM)
(KTYPE)))
XITF (AND ARITHP (SETQ XPR (CONS XPR TYP)))
(SETQ TEM P1LSQ)
(RETURN NIL)
XITEM (SETQ XPR TEM)
(GO XITF))
(P1SQE TEM)
XPR)
(DEFUN P1AEVAL (FUN TYP ARGL SAVXPR)
((LAMBDA (TEM)
(AND (DO ((Z ARGL (CDR Z))) ((NULL Z) T)
(AND (OR (ATOM (CAR Z)) (NOT (EQ (CAAR Z) 'QUOTE)))
(RETURN NIL)))
(COND ((ERRSET (SETQ TEM (EVAL (CONS FUN ARGL))) NIL)
(LIST 'QUOTE TEM))
(T (PDERR SAVXPR |ILGL ARITHMETIC CONSTRUCTION|)
''NIL))))
NIL))
(DEFUN P1ANDOR (X ORP)
(PROG (Z)
(COND ((NULL (CDR X)) (RETURN (P1 (NOT ORP))))
((NULL (CDDR X)) (RETURN (P1 (CADR X))))
(EFFS (RETURN (P1COND (CAR X) (CDR X)))))
(SETQ Z (COND (ORP (MAPCAR 'NCONS (CDR X)))
(T (SETQ Z (L2F (CDR X))) ;CONVERT (AND A B C)
(LIST (LIST (CONS 'AND (CDR Z)) (CAR Z)))))) ;INTO (COND ((AND B) C))
(RETURN (P1COND 'COND Z))))
(DEFUN P1BINDARG (SPFL VAR OARG)
((LAMBDA (TYP ARG KTYPE ARITHP PNOB EFFS)
(SETQ TYP KTYPE)
(COND ((AND SPFL (NULL TYP)) (SETQ ARITHP NIL) (P1 OARG)) ;SPECIAL, NON-NUMERIC VAR
(TYP
(SETQ ARG (P1 OARG))
(COND ((COND ((CDR ARG) (NOT (EQ (CDR ARG) TYP)))
((NOTNUMP (CAR ARG))))
(PDERR (LIST VAR OARG)
|BINDING NUMBER VARIABLE TO QUANTITY OF WRONG TYPE|)
(COND ((EQ TYP 'FIXNUM) ''1) (''1.0)))
((CAR ARG))))
((COND ((NULL (SETQ ARG (NUMTYP OARG NIL))) NIL) ;LOCAL-LIST-TYPE-VAR BEING
((EQ (SETQ TYP (TYPEP (CAR ARG))) 'SYMBOL) ;BOUND TO SOMETHING THAT
(NOT #(SPECIALP (CAR ARG)))) ;JUST MIGHT BE A PDLNUM
((EQ TYP 'LIST) (NOT (EQ (CAAR ARG) 'COND)))
((NOT (MEMQ TYP '(FIXNUM FLONUM)))))
(SETQ ARG (P1 OARG))
(NLNVEX VAR
(COND ((CDR ARG)
(SETQ CNT (+ CNT 2))
(CADR (SETQ ARG (LIST 'SETQ (NLNVCR VAR (CDR ARG)) (CAR ARG)))))
(T (UNSAFEP (SETQ ARG (CAR ARG))))))
ARG)
(T (SETQ PNOB VAR ARG (P1 OARG) OARG (UNSAFEP (CAR ARG)))
(AND OARG
(OR (NOT (ATOM OARG)) (NUMERVARP OARG)) ;SEE NOTE BELOW
(NLNVEX VAR OARG))
(CAR ARG))))
NIL NIL (VARMODE VAR) T NIL NIL))
;;; NOTE: WE DONT WANT A VAR X TO GET UNSAFE JUST BECAUSE IT OCCURS SOMEWHERE (SETQ X Y)
;;; AND Y IS UNSAFE [WHERE BOTH X AND Y ARE LLTVS
(DEFUN P1BUG (P1CNT P1VARS)
(SETQ CNT (ADD1 CNT))
(DO X P1VARS (CDR X) (NULL X)
(COND ((GREATERP (CDAR X) P1CNT) (RPLACD (CAR X) CNT))))
(SETQ CNT (ADD1 CNT)))
(DEFUN P1CARCDR (X)
(PROG (Y TEM)
(COND ((OR (NULL (CDR X)) (CDDR X))
#(PDERR X |WRONG NUMBER OF ARGUMENTS|)
(SETQ Y ''NIL) (GO XIT)))
(SETQ Y (P1VAP (CADR X) NIL))
(AND (CDR Y)
(PDERR X |ATTEMPT TO TAKE CAR OR CDR OF A NUMERIC QUANTITY|))
(SETQ Y (CAR Y))
(COND ((AND (SETQ TEM (NOT (ATOM Y))) ;(CAR (CDR X))
(NOT (ATOM (CAR Y))) ;GOES FIRST INTO
(EQ (CAAR Y) CARCDR)) ;(CAR ((CARCDR D) X)) THEN TO
(NCONC (CAR Y) (P1CCEXPLODE (CAR X)))) ;((CARCDR D A) X)
((AND TEM (EQ (CAR X) 'CDR) (EQ (CAR Y) 'RPLACD))
(SETQ Y (CONS '(RPLACD) (CDR Y))))
(T (SETQ Y (LIST (CONS CARCDR (P1CCEXPLODE (CAR X))) Y))))
XIT (RETURN (COND (ARITHP (NCONS Y)) (Y)))))
(DEFUN P1CARCDR-CHASE (X)
(COND ((ATOM X))
((NULL (CDR X)) NIL)
((CDDR X) NIL)
((AND #(SYMBOLP (CAR X)) (GET (CAR X) 'CARCDR))
(P1CARCDR-CHASE (CADR X)))))
(DEFUN P1CCEXPLODE (FUN)
(DO ((FUN (GET FUN 'CARCDR) (GET FUN 'CARCDR)) (L NIL))
((NULL FUN) L)
#(PUSH (CAR FUN) L)
(SETQ FUN (CADR FUN))))
(DEFUN P1CONS (L)
(COND ((NULL L) '(QUOTE NIL))
(T (LIST 'CONS (CAR L) (P1CONS (CDR L))))))
;;; THE CONDTYPE VAR HAS A RIGID FORMAT - SEE P1TYPE-ADD
(DEFUN P1COND (FUN X)
(PROG (P1VARS P1CNT BODY CONDTYPE CONDUNSF CONDPNOB
CONDP P1CSQ LMBP P1LSQ P1CCX ARITHP)
(SETQ P1VARS LOCVARS P1CNT CNT CONDP T P1CCX 0)
(SETQ BODY (XCONS (MAPCAR '(LAMBDA (X) (COND ((EQ FUN 'COND) (P1CDC X))
((P1AOC X))))
X)
(COND ((NOT (EQ FUN 'COND)) NIL)
((NULL (CDR CONDTYPE)) KTYPE)
((NULL KTYPE)
(COND ((CDDR CONDTYPE) NIL)
((AND (CAR CONDTYPE)
(EQ (CAR CONDTYPE) (CADR CONDTYPE)))
(CAR CONDTYPE))
(CONDTYPE)))
((OR (CDDR CONDTYPE)
(NOT (EQ KTYPE (CADR CONDTYPE)))
(AND (CAR CONDTYPE)
(NOT (EQ KTYPE (CAR CONDTYPE)))))
(PDERR (CONS FUN X) |COND HAS CLAUSE OF WRONG NUMERIC TYPE|)
NIL)
(KTYPE))))
(SETQ X (CONS FUN (CONS P1CCX (CONS P1CSQ (CONS CONDUNSF BODY)))))
(P1BUG P1CNT P1VARS))
(P1SQE (CADDR X))
(COND (ARITHP (OR (ATOM (SETQ FUN (CADDDR (CDR X)))) (SETQ FUN NIL)) (CONS X FUN))
(X)))
(DEFUN P1AOC (J)
; COMPILE A PIECE IN AN AND-OR CLAUSE, OR THE FIRST PART OF A COND CLAUSE
(COND ((P1BOOL1ABLE J) (P1E J)) ;IF MEMQ IS NOT BOOL1ABLE, THEN NEED SPECIAL CHECK
((P1VN J)))) ;FOR (MEMQ X '(A B)) TO GO INTO (OR (EQ X A) (EQ X B))
(DEFUN P1BOOL1ABLE (X)
(COND ((OR (ATOM X) (NOT (ATOM (CAR X)))) NIL)
((EQ (CAR X) 'PROG2) (AND (NULL (CDDDR X)) (P1BOOL1ABLE (CADDR X))))
(((LAMBDA (PROP)
(COND ((NULL PROP) NIL)
((EQ PROP 'NUMBERP)
(COND (CLOSED NIL)
((OR (NULL P2P)
(MEMQ (CADR X) '(FIXNUM FLONUM)))
X)))
(T X))) ;PROP MUST BE EITHER T OR A FIXNUM HERE
(GET (CAR X) 'P1BOOL1ABLE)))))
;;; ON P1, WHEN IT IS THE "NUMBERP" CASE SUCH AS "PLUSP, OR "GREATERP",
;;; THIS MAY ANSWER YES FALSELY, SINCE WE DONT KNOW WHETHER OR NOT
;;; ALL THE ARITHMETICS ARE OF THE SAME TYPE
(DEFUN P1BASICBOOL1ABLE (X) (AND (SETQ X (P1BOOL1ABLE X)) (NOT (MEMQ (CAR X) '(AND OR MEMQ COND)))))
(DEFUN P1CDC (J) ;P1 COND CLAUSE ANALYZER
(COND ((NOT (EQ (TYPEP J) 'LIST))
(PDERR J |RANDOM COND CLAUSE|)
'('NIL))
((COND ((NULL (CDR J)))
((CDDR J) NIL)
((AND (OR (EQ (CADR J) T) ;LIKE ((EQ X Y) T) OR
(AND (NOT (ATOM (CADR J))) ;OR ((NULL BARF) (QUOTE T))
(EQ (CAADR J) 'QUOTE)
(EQ (CADADR J) T)))
(P1BASICBOOL1ABLE (CAR J)))
(SETQ J (LIST (CAR J)))
T))
(COND ((ATOM (CAR J)) (P1CJ J))
((MEMQ (CAAR J) '(GO RETURN)) (P1CDC (CONS T J)))
(EFFS (LIST (P1AOC (CAR J))))
((OR (P1BASICBOOL1ABLE (CAR J))
(AND (EQ (CAAR J) 'OR)
(CDAR J)
(CDDAR J)
(P1BASICBOOL1ABLE (CADDAR J))
(P1BASICBOOL1ABLE (CADR J))))
(CONS (P1E (CAR J)) (P1CJ '(T))))
(T (P1CJ J))))
((AND (NOT EFFS)
(NULL (CDDR J)) ;((NULL FOO) NIL)
(OR (EQ (CAAR J) 'NULL) (EQ (CAAR J) 'NOT))
(OR (NULL (CADR J)) (QNILP (CAAR J)))
(OR (NOT (P1BOOL1ABLE (CADAR J))) (EQ (CAADAR J) 'MEMQ)))
(NREVERSE (CONS NULFU (P1CJ (CDAR J)))))
((CONS (P1AOC (CAR J))
(COND ((NULL (CDDR J)) (P1CJ (CDR J)))
(T (SETQ J (L2F (CDR J)))
(NRECONC (DO ((LL (CDR J) (CDR LL)) (Z) (ARITHP) (EFFS))
((NULL LL) Z )
#(PUSH (P1 (CAR LL)) Z))
(P1CJ J))))))))
(DEFUN P1CJ (J)
((LAMBDA (ARITHP MODE FL)
(SETQ J (P1 (CAR J)))
(COND (ARITHP
(SETQ MODE (CDR J) J (CAR J))
(SETQ P1CCX (PLUS P1CCX (P1TRESS J)))
(COND ((NOT (SETQ FL (UNSAFEP J))))
((NOT (ATOM FL)) (SETQ CONDUNSF (LADD FL CONDUNSF) FL T))
((NULL (VARMODE FL)) #(PUSH FL CONDUNSF) (SETQ FL NIL))
((SETQ FL GOFOO))) ;LOCAL NUMERIC TYPE VARS ARE ALWAYS UNSAFE
;SO DONT NEED TO PUT EXPLICITLY ON UNSFLST
(SETQ CONDTYPE (P1TYPE-ADD CONDTYPE MODE))))
(COND ((AND PNOB ;IF A PDL NUMBER IS IN ORDER
MODE ;AND VAL IS NUMERIC,
(NOT (EQ FL GOFOO)) ;BUT NOT FIXNUMVAR
(OR FL (P1CJ-NUMVALP J))) ;THEN MIGHT NEED NLNVTHTBP
(AND (NULL CONDPNOB) (SETQ CONDPNOB (CONS NIL NIL)))
(SETQ CNT (+ CNT 2) FL NIL)
(SETQ MODE (COND ((EQ MODE 'FIXNUM)
(AND (NULL (CAR CONDPNOB))
(RPLACA CONDPNOB (SETQ FL (NLNVFINDCR MODE 'COND))))
(CAR CONDPNOB))
((EQ MODE 'FLONUM)
(AND (NULL (CDR CONDPNOB))
(RPLACD CONDPNOB (SETQ FL (NLNVFINDCR MODE 'COND))))
(CDR CONDPNOB))))
;MODE NOW HAS NAME OF NLNVTHTBP, EITHER FIXNUM OR FLONUM, FOR THE WINGS OF THE COND
;FL IS NON-NIL IF NAME IS NEWLY CREATED
(AND FL (NOT (EQ CONDUNSF T)) #(PUSH MODE CONDUNSF))
(SETQ J (CONS 'SETQ (LIST MODE J)))))
(NCONS J))
(NOT EFFS) NIL NIL))
;;;BASICALLY, A PHASE2 TYPE ANALYZER, EXCEPT THAT QUOTED NUMBERS
;;;AND VARIALBES ARE IGNORED. CALLED ONLY BY P1CJ.
(DEFUN P1CJ-NUMVALP (FORM)
(COND ((ATOM FORM) NIL)
((NOT (ATOM (CAR FORM)))
(COND ((EQ (CAAR FORM) 'LAMBDA) (P1CJ-NUMVALP (CADDDR (CDDAR FORM))))
((EQ (CAAR FORM) COMP)
(AND (MEMQ (CADAR FORM) '(FIXNUM FLONUM)) (CADAR FORM)))))
((MEMQ (CAR FORM) '(SETQ QUOTE)) NIL)
((EQ (CAR FORM) 'PROG2) (P1CJ-NUMVALP (CADDR FORM)))
((OR (EQ (CAR FORM) 'PROGN) (EQ (CAR FORM) PROGN) (EQ (CAR FORM) 'PROGV))
(P1CJ-NUMVALP (CAR (LAST (CDR FORM)))))
((AND (SETQ FORM (NUMFUNP FORM NIL)) (NOT (EQ FORM T))) FORM)))
(DEFUN DOEXPANDER (X)
(PROG (INDXL ENDTST ENDVAL TG1 TAG3 PVARS LVARS STEPDVARS LVALS BODY DECL)
(COND ((AND (CAR #(POP X)) (ATOM (CAR X))) ;POP GETS RID OF "DO"
(SETQ INDXL (LIST (LIST (CAR X) (CADR X) (CADDR X)))
ENDTST (CAR (SETQ X (CDDDR X)))
ENDVAL NIL))
(T (SETQ INDXL (REVERSE (CAR X)))
(COND ((CAR #(POP X))
(SETQ ENDTST (CAAR X)
ENDVAL (COND ((OR (NULL (CDAR X))
(NULL (CADAR X))
(AND (NOT (ATOM (CADAR X)))
(QNILP (CADAR X))))
NIL)
(T (REVERSE (CDAR X))))))
(T (SETQ ENDTST CLPROGN)))))
(MAPC '(LAMBDA (X) (COND ((ATOM X) (ERR GOFOO))
((NULL (CDR X)) #(PUSH (CAR X) PVARS))
(T #(PUSH (CAR X) LVARS)
#(PUSH (CADR X) LVALS)
(AND (CDDR X) #(PUSH X STEPDVARS)))))
INDXL)
#(POP X)
(AND (NOT (EQ ENDTST CLPROGN)) (SETQ TG1 (LIST (GENSYM))))
(SETQ BODY (LIST
(NCONC (LIST 'PROG PVARS)
TG1
(AND (NOT (EQ ENDTST CLPROGN))
ENDTST
(OR (ATOM ENDTST) (NOT (QNILP ENDTST)))
(LIST
(LIST
'COND
(CONS ENDTST
(COND ((NULL ENDVAL) '((RETURN (QUOTE NIL))))
(TAG3 (LIST (LIST 'GO TAG3)))
(T (DORETURN ENDVAL)))))))
(APPEND (COND ((AND (NOT (ATOM X)) (EQ (CAAR X) 'DECLARE))
(SETQ DECL (CAR X))
(CDR X))
(X))
NIL)
(AND STEPDVARS (LIST (DOSTEPPER STEPDVARS)))
(LIST (COND (TG1 (LIST 'GO (CAR TG1)))
((EQ ENDTST CLPROGN) (LIST 'RETURN NIL))
((ERR GOFOO))))
(AND TAG3 (CONS TAG3 (DORETURN ENDVAL))))))
(AND DECL (SETQ BODY (CONS DECL BODY)))
(RETURN (CONS (CONS 'LAMBDA (CONS LVARS BODY)) LVALS))))
(DEFUN DORETURN (ENDVAL) (NREVERSE (CONS (LIST 'RETURN (CAR ENDVAL)) (CDR ENDVAL))))
(DEFUN DOSTEPPER (L)
(COND ((NULL L) NIL)
((LIST 'SETQ
(CAAR L)
(COND ((NULL (CDR L)) (CADDAR L))
((LIST 'PROG2 NIL (CADDAR L) (DOSTEPPER (CDR L)))))))))
(DEFUN P1EQQTE (Z)
(AND (NOT (ATOM Z))
(EQ (CAR Z) 'QUOTE)
#(SYMBOLP (CADR Z))))
(DEFUN P1E (X) ((LAMBDA (EFFS) (P1 X)) T))
(DEFUN P1E1 (X)
; CALLED ONLY FROM P1PROG
; TRIES TO FACTOR OUT A SETQ FROM A COND - FOR EXAMPLE,
; (COND ((AND (SETQ X (FOO)) ALPHA) (RETURN NIL)))
; GOES INTO
; (PROG2 (SETQ X (FOO)) (COND ((AND X ALPHA) (RETURN NIL))))
(COND ((OR PRSSL (NOT (MEMQ (CAR X) '(COND AND OR)))) (P1 X))
(((LAMBDA (DATA TEM F)
(AND (SETQ DATA (P1HUNOZ (SETQ TEM (COND (F (CADR X))
((CDR X))))))
(OR (MEMQ (CADR DATA) BVARS)
(ASSQ (CADR DATA) RNL))
(P1 (PROG2 (SETQ TEM (P1HUNOZ TEM))
(LIST 'PROG2
DATA
(CONS (CAR X)
(COND (F (CONS TEM (CDDR X)))
(TEM))))))))
NIL NIL (EQ (CAR X) 'COND)))
((P1 X))))
(DEFUN P1HUNOZ (Y) (COND ((OR (ATOM (CAR Y))
(NULL (CDAR Y))
(NOT (ATOM (CAAR Y)))
(ASSQ (CAAR Y) MACROLIST))
(AND DATA Y))
((EQ (CAAR Y) 'SETQ) (COND (DATA (CONS (P1FV (CDAR Y)) (CDR Y)))
(T (CAR Y))))
((GETL (CAAR Y) '(FEXPR FSUBR *FEXPR MACRO)) (AND DATA Y))
(DATA (CONS (CONS (CAAR Y) (P1HUNOZ (CDAR Y))) (CDR Y)))
((P1HUNOZ (CDAR Y)))))
(DEFUN P1F (F L)
; PATCH UP FOR FORMS OF (EVAL (CONS 'FSUBR LIST))
(AND (P1KNOWN F '(FSUBR *FEXPR)) (CONS (CONS 'FSUBR (CADR F)) L)))
(DEFUN P1FAKE (X)
; CONVERT FOO INTO ((LAMBDA NIL FOO)) SO THAT
; THE SETQ COUNT AND CLEAR ING ACTION OF LAMBDA
; FORM WILL BE DONE FOR FOO
((LAMBDA (Z)
(RPLACA (CADDDR (CDDAR Z)) (CAR X))
(P1MODESET Z))
(P1VN (LIST (LIST 'LAMBDA NIL (CONS NULFU (CDR X)))))))
(DEFUN P1FV (X)
(COND ((AND (CDR X) (CDDR X)) (P1FV (CDDR X)))
((CAR X))))
(DEFUN P1FUNGET (FUN) ;IDEA IS TO CONVERT '(LAMBDA . . .)
(PROG NIL ; TO (FUNCTION (LAMBDA . . .))
A (COND ((ATOM FUN))
((EQ (CAR FUN) 'FUNCTION) (RETURN FUN))
((EQ (CAR FUN) 'QUOTE) (RETURN (CONS 'FUNCTION (CDR FUN))))
((AND (SETQ FUN (P1MACROGET FUN))
(NOT (EQ (CAR FUN) GOFOO))
(NOT (EQ (CAR FUN) NULFU)))
(GO A)))))
(DEFUN P1GFY (X FL)
(COND ((ATOM X) X)
(T (SETQ X (COMPILE (P1PFX) FL X NIL T))
(AND (NOT FASLPUSH) (COUTPUT GOFOO))
X)))
(DEFUN P1PFX NIL (MAKNAM (APPEND GENPREFIX (EXPLODEC (SETQ GFYC (ADD1 GFYC))))))
(DEFUN P1GLM (LL BODY)
((LAMBDA (T1 MODE FL)
(COND ((NULL (CDR BODY))
(SETQ T1 (P1 (CAR BODY)))
(SETQ BODY (COND (ARITHP (CAR T1)) (T1))))
(T (SETQ BODY (P1L BODY EFFS ARITHP KTYPE))
(SETQ T1 (CAR (SETQ FL (LAST BODY))))
(AND ARITHP (RPLACA FL (CAR T1)))
(SETQ BODY (CONS PROGN BODY))))
(AND ARITHP (SETQ MODE (CDR T1) T1 (CAR T1)))
(NLNVASG P1LL)
(P1GLM1 LL
BODY
(COND ((OR EFFS (ZEROP (P1TRESS T1))) 0) (1))
(OR MODE KTYPE)
(COND ((NULL (SETQ FL (UNSAFEP T1))) NIL)
((ATOM FL) (LIST FL))
(FL))))
NIL NIL NIL))
(DEFUN P1GLM1 (LL BODY N MODE UNSAFEP)
((LAMBDA (T1)
(COND ((NOT ARITHP) T1)
((CONS T1 MODE))))
(LIST 'LAMBDA N P1LSQ MODELIST LL BODY CNT UNSAFEP NLNVTHTBP)))
(DEFUN P1LABEL (X)
(PROG (Y TEM)
(PUTPROP (SETQ Y (CADAR X)) T 'SPECIAL)
(PUTPROP (SETQ TEM (P1PFX)) T '*EXPR)
(COMPILE TEM 'EXPR (CADDAR X) (LIST (CONS Y TEM)) NIL)
(RETURN (P1LAM (LIST 'LAMBDA (LIST Y) (CONS TEM (CDR X)))
(LIST (LIST 'QUOTE TEM))))))
(DEFUN P1LAM (F ARGS)
((LAMBDA (OLVRL P1LL OLDRNL OBVARS RNL BVARS CONDP LMBP P1LSQ
OMODELIST MODELIST NLNVTHTBP TEM)
(SETQ F (CDDR F))
(COND ((EQ (CAAR F) 'DECLARE) (LCLDECLARE F) (SETQ F (CDR F))))
(SETQ P1LL (P1LMBIFY P1LL P1LL NIL))
(COND ((NOT (ZEROP (SETQ TEM (- (LENGTH ARGS) (LENGTH P1LL)))))
(PDERR (CONS (CONS 'LAMBDA (CONS P1LL F)) ARGS)
|WRONG NUMBER OF ARGS|)
(DO ((Z) (I TEM (1- I)))
((SIGNP LE I)
(COND (Z (P1LMBIFY Z Z NIL) (SETQ P1LL (NCONC Z P1LL)))))
#(PUSH (GENSYM) Z))))
(DO ((RNL OLDRNL) (BVARS OBVARS) (MODELIST OMODELIST) (P1LLCEK P1LL)
(Z P1LL (CDR Z)) (ZZ ARGS (CDR ZZ)) (Y))
((NULL Z) (SETQ ARGS (NREVERSE Y)))
#(PUSH (P1BINDARG #(SPECIALP (CAR Z)) (CAR Z) (CAR ZZ))
Y))
(SETQ TEM (P1GLM P1LL F))
(P1SPECIALIZEDVS) ;CHECK FOR SCREW CASE
(SETQ CNT (1+ CNT))
(SETQ ARGS (COND (ARITHP (RPLACA TEM (CONS (CAR TEM) ARGS)))
((CONS TEM ARGS))))
(UUVP P1LL 'P1LL 'LAMBDA)
(SETQ F P1LSQ))
(LJOIN OLVRL P1LL) (CADR F) RNL BVARS RNL BVARS NIL
T NIL MODELIST MODELIST NIL NIL)
(P1SQE F)
ARGS)
(DEFUN P1LST (X)
(PROG (Z LL V)
(SETQ Z (CDR X))
(COND ((MEMQ (CAR X) '(MEMBER ASSOC SASSOC)) ;CONVERTO TO MEMQ, ASSQ, SASSQ IF POSSIBLE
(AND (OR (NULL (CADR Z)) (QNILP (CADR Z)))
(RETURN (P1 (LIST 'PROG2 (CAR Z) NIL))))
(AND (COND ((P1EQQTE (CAR Z)))
((NULL (SETQ LL (P1LST-LSTGET (CADR Z)))) NIL)
((NOT (DO Y LL (CDR Y) (NULL Y)
(AND (NOT #(SYMBOLP (COND ((EQ (CAR X) 'MEMBER) (CAR Y))
(T (CAAR Y)))))
(RETURN T))))))
(SETQ X (CONS (CDR (ASSQ (CAR X) '((MEMBER . MEMQ)
(ASSOC . ASSQ)
(SASSOC . SASSQ))))
(CDR X))))))
(COND ((NOT (AND EFFS
(EQ (CAR X) 'MEMQ)
(OR LL (SETQ LL (P1LST-LSTGET (CADR Z))))
(LESSP (LENGTH LL) 5))))
((P1CARCDR-CHASE (SETQ V (CAR Z)))
(RETURN (P1 (CONS 'OR (MAPCAR '(LAMBDA (X) (LIST 'EQ V (LIST 'QUOTE X))) LL)))))
((COND ((EQ (CAR V) 'SETQ) (SETQ LL V V (NX2LAST V)) T)
((AND (EQ (CAR V) 'PROG2)
(AND (CDDR V) (NULL (CDDDR V)))
(P1CARCDR-CHASE (CADDR V)))
(SETQ LL (CADR V) V (CADDR V))
T))
(RETURN (P1 (LIST 'PROG2 LL (CONS 'MEMQ (CONS V (CDR Z))))))))
(SETQ Z (MAPCAR 'P1VN (CDR X)))
(AND (EQ (CAR X) 'EQUAL)
(OR (P1EQQTE (CAR Z)) (P1EQQTE (CADR Z)))
(SETQ X '(EQ)))
(SETQ X (CONS (CAR X) Z))
(RETURN (COND (ARITHP (NCONS X)) (X)))))
(DEFUN P1LST-LSTGET (Z)
(COND ((OR (ATOM Z) (NOT (EQ (CAR Z) 'QUOTE))) NIL)
((NULL (CADR Z)) NIL)
((NOT (EQ (TYPEP (CADR Z)) 'LIST)) (PDERR Z |CANT USE THIS AS 2ND ARG TO MEMQ|))
((CADR Z))))
(DEFUN P1KNOWN (F L)
(AND (NOT (ATOM F))
(MEMQ (CAR F) '(QUOTE FUNCTION))
(ATOM (SETQ F (CADR F)))
(SETQ L (GETL F L))
(OR (NOT (MEMQ (CAR L) '(SUBR FSUBR LSUBR)))
(SYSP (CADR L)))))
(DEFUN P1L (X OEFFS OARITHP OKTYPE)
((LAMBDA (EFFS ARITHP KTYPE)
(MAPLIST '(LAMBDA (X)
(AND (NULL (CDR X))
(SETQ EFFS OEFFS ARITHP OARITHP KTYPE OKTYPE))
(P1 (CAR X)))
X))
T NIL NIL))
(DEFUN P1LMBIFY (LL NAME TYPES)
(AND TYPES (SETQ TYPES (CDDR TYPES)))
(MAPLIST (FUNCTION
(LAMBDA (Y)
(COND ((OR (NULL (CAR Y)) (EQ (CAR Y) T))
(PDERR NAME |NIL AND T NOT PERMISSIBLE IN BOUND VAR LIST|))
((MEMQ (CAR Y) (CDR Y))
(WARN (LIST (CAR Y) 'FROM NAME)
|- REPEATED IN BOUND VAR LIST|
3 6)))
(SETQ Y (CAR Y))
(COND (#(SPECIALP Y))
((AND SPECIAL (NOT (GET Y 'P1M-NOSPEC)))
(PUTPROP Y T 'SPECIAL))
(T (COND ((ASSQ Y LOCVARS)
#(PUSH (CONS Y (GENSYM)) RNL)
(AND (SETQ Y (VARMODE Y))
#(PUSH (CONS (CDAR RNL) Y) MODELIST))
(SETQ Y (CDAR RNL))))
(PUTPROP Y NIL 'OHOME) ;JUST TO BE SURE THAT OHOME PROP EXISTS
#(PUSH (CONS Y 0) LOCVARS)))
#(PUSH Y BVARS)
(COND (TYPES (AND (CAR TYPES)
(NOT (EQ (CAR TYPES) (VARMODE Y)))
#(PUSH (CONS Y (CAR TYPES)) MODELIST))
#(POP TYPES)))
Y))
LL))
(DEFUN P1MAP (X Z)
(PROG (Y TEM CCSLD FUN)
A (SETQ Y NIL CCSLD T)
(COND ((SETQ TEM (ATOM (SETQ FUN (CAR X))))) ;RANDOM VARIABLE FUNCTION
((MEMQ (CAR FUN) '(QUOTE FUNCTION))
(SETQ Y (COND ((SETQ TEM (ATOM (CADR FUN)))
(SETQ CCSLD (NOT (P1KNOWN (CADR FUN) '(SUBR FSUBR LSUBR))))
T)
((MEMQ (CAADR FUN) '(LAMBDA LABEL))))))
((OR (NULL (SETQ FUN (P1MACROGET FUN))) (EQ (CAR FUN) GOFOO) (EQ (CAR FUN) NULFU)))
(T (SETQ X (CONS (CAR FUN) (CDR X))) (GO A)))
(AND Y ;CONVERT '(LAMBDA FOO)
(NULL TEM)
(EQ (CAAR X) 'QUOTE) ;INTO (FUNCTION (LAMBDA FOO))
(SETQ X (CONS (LIST 'FUNCTION (CADAR X)) (CDR X))))
(AND Y
(OR (AND MAPEX (NOT (AND Y TEM (GETL (CADAR X) '(FSUBR *FEXPR)))))
(AND (NOT TEM)
(EQ (CATCH (SETQ X (CONS (LIST 'QUOTE
((LAMBDA (CFVFL) (P1GFY (CADAR X) 'LEXPR))
(CONS (CONS BVARS RNL) CFVFL)))
(CDR X)))
CFVFL)
'CFVFL)))
(GO MAPEXPAND))
(AND CCSLD (P1SQV PROGN))
(RETURN (P1FAKE (CONS (CONS '*MAP (CONS CCSLD (COND ((OR (CDDR X) (NULL (CDR Z))) Z)
(T (CADR Z))))) X)))
MAPEXPAND
(COND ((EQ (CAR Z) 'MAPATOMS)
(AND (NULL (CDR X)) (SETQ X (CONS (CAR X) '(OBARRAY))))
(SETQ TEM (SUBLIS (LIST (CONS 'PVR (CAR X)) (CONS 'STSL (CADR X)) (CONS 'VL (GENSYM)))
'(DO VL (- (CADR (ARRAYDIMS STSL)) 129.) (1- VL) (MINUSP VL)
(DECLARE (FIXNUM VL))
(MAPC PVR (ARRAYCALL T STSL VL)))))
(RETURN ((LAMBDA (MAPEX) (P1 TEM)) T))))
(SETQ TEM NIL) ;TO LOOK FOR MAPC'S FOR VALUE!!
((LAMBDA (FORM INDICL) ;INDICL IS THE DO INDICES LIST, FORM IS THE FORMAT
(RPLACD (CAR MAPSB) INDICL) ;INSTALL INDICES LIST IN SUBSTITION LIST
(RPLACD (CADR MAPSB) ;INSTALL THE EXIT TEST
(LIST (COND ((NULL (CDR INDICL)) (LIST 'NULL (CAAR INDICL)))
((CONS 'OR (MAPCAR '(LAMBDA (X) (LIST 'NULL (CAR X)))
INDICL))))))
(RPLACD (CAR (SETQ Y (CDDR MAPSB)))
(CONS (CADAR X)
(MAPCAR '(LAMBDA (X) (COND ((EQ (CADDDR Z) 'LIST) (CAR X))
((LIST 'CAR (CAR X)))))
INDICL)))
(COND ((NOT EFFS)
(SETQ Y (CDR Y)) ;POSITION Y OVER ((PVR) (STSL) . . .)
(COND (TEM (RPLACD (CAR Y) (CAR TEM))
(RPLACD (CADR Y) (CDR TEM)))
(T (RPLACD (CAR Y) (P1M-NOSPEC))
(RPLACD (CADR Y) (P1M-NOSPEC))))))
;FORMAT OF MAPSB IS ((VL . NIL) (EXIT . NIL) (USR . NIL)
; (PVR . NIL) (STSL . NIL) (GOFOO . GOFOO))
(SETQ X (SUBLIS MAPSB FORM))) ;SUBSTITUTE INTO THE EXPANDER FORM
(COND (EFFS '(DO VL EXIT USR)) ;IF NOT FOR VALUE, THEN SIMPLE DO
((EQ (CADDR Z) 'MAP)
(SETQ TEM (CONS (P1M-NOSPEC) (CADR X))) ;THIS WILL BE VALUE FOR PVR BELOW
(SETQ X (CONS (CAR X) (CONS (CAR TEM) (CDDR X))))
;STSL WILL BECOME THE FIRST OF THE LIST BEING MAPPED DOWN
'((LAMBDA (PVR) (DO VL EXIT USR) PVR) STSL))
((EQ (CADDR Z) 'MAPCON)
'((LAMBDA (PVR STSL)
(GOFOO PVR STSL)
(DO VL EXIT (SETQ STSL (LAST (RPLACD STSL USR))))
PVR)
NIL NIL))
('((LAMBDA (PVR STSL)
(GOFOO PVR STSL)
(DO VL EXIT (SETQ STSL (CDR (RPLACD STSL (LIST USR)))))
PVR)
NIL NIL)))
(MAPCAR '(LAMBDA (Z) (LIST (SETQ Y (P1M-NOSPEC)) Z (LIST 'CDR Y))) (CDR X)))
(RETURN (P1 X))))
(DEFUN P1M-NOSPEC NIL
((LAMBDA (X)
(AND SPECIAL (PUTPROP X T 'P1M-NOSPEC))
X)
(GENSYM)))
(DEFUN P1MACROGET (X)
((LAMBDA (Z)
(COND ((NOT (OR (AND Z (SETQ Z (CDR Z)))
(SETQ Z (GET (CAR X) 'MACRO))))
NIL)
((NULL (SETQ Z (ERRSET (FUNCALL Z X) NIL))) (LIST NULFU))
((ATOM Z) (LIST Z))
(Z)))
(ASSQ (CAR X) MACROLIST)))
(DEFUN P1MODESET (XPR)
(COND ((NOT ARITHP) XPR)
(T ((LAMBDA (TEMP FORM)
(CONS XPR
(COND ((ATOM FORM) (VARMODE FORM))
((AND (NOT (SETQ TEMP (ATOM (CAR FORM))))
(NOT (EQ (CAAR FORM) 'LAMBDA)))
NIL)
((COND ((NOT TEMP) ;IMPLIES A LAMBDA
(SETQ FORM (CADDR (CDDDAR FORM)))
(AND (NOT (ATOM FORM))
(EQ (CAR FORM) PROGN)
(SETQ FORM (CAR (LAST FORM))))
(COND ((ATOM FORM) (SETQ TEMP (VARMODE FORM)) T)
((NOT (ATOM (CAR FORM))) (SETQ TEMP NIL) T)))
((EQ (CAR FORM) 'ARRAYCALL) (SETQ TEMP (CADR FORM)) T))
TEMP)
((SETQ TEMP (OR (GET (CAR FORM) 'NUMFUN) (FUNMODE (CAR FORM))))
(CADR TEMP)))))
NIL XPR))))
(DEFUN P1PROG (X)
(PROG2 NIL
((LAMBDA (OPVRL MODELIST RNL BVARS PROGP EFFS P1PCX OARITHP PKTYP)
(PROG (CONDP P1CSQ LMBP P1LSQ PVRL P1VARS GL P1CNT PROGPNOB KTYPE
ARITHP GONE2 P1PSQ BODY PRSSL PROGTYPE PROGUNSF NLNVTHTBP)
(SETQ P1VARS (CAR X) X (CDR X))
(COND ((EQ (CAAR X) 'DECLARE)
(LCLDECLARE X)
(SETQ X (CDR X))))
(AND P1LL (NOT (MEMQ P1LL OPVRL)) #(PUSH P1LL OPVRL))
(SETQ PVRL (P1LMBIFY P1VARS P1VARS NIL))
(SETQ P1VARS LOCVARS)
(SETQ P1CNT (SETQ CNT (ADD1 CNT)))
(SETQ BODY
(MAPCAR
'(LAMBDA (Y)
(PROG NIL
(SETQ CNT (ADD1 CNT))
A (COND ((SETQ BODY (ATOM Y)))
((NULL (SETQ BODY (P1MACROGET Y))))
((OR (EQ (CAR BODY) GOFOO)
(EQ (CAR BODY) NULFU))
(SETQ BODY NIL))
(T (SETQ Y (CAR BODY)) (GO A)))
(COND (BODY
(SETQ PRSSL T)
(SETQ Y (P1TAG Y))
(SETQ GL #(PUSH (CONS Y (GENSYM)) GL))
(AND (ASSQ Y (CDR GL))
(NOT (EQ Y GOFOO))
(WARN Y |REPEATED GO TAG|))
(RETURN Y))
(T (RETURN (P1E1 Y))))))
X))
(P1SPECIALIZEDVS) ;CHECK FOR SCREW CASE
(P1BUG P1CNT P1VARS)
(UUVP PVRL 'PVRL 'PROG)
(COND ((MEMQ GOFOO GONE2))
; GOFOO ON GONE2 SAYS THERE IS A COMPUTED GO
(T (MAPC '(LAMBDA (TAG) (AND (NOT (MEMQ (CAR TAG) GONE2))
(SETQ GL (DELETE TAG GL))))
GL)))
(MAPC '(LAMBDA (TAG) (AND (NOT (ASSQ TAG GL))
(NOT (EQ TAG GOFOO))
(PDERR (LIST 'GO TAG)
|GO TO NON-EXISTENT TAG|)))
GONE2)
(SETQ X P1PSQ)
(NLNVASG PVRL)
; HERE IS RETURN VALUE, PUT IN GONE2
(SETQ GONE2 (LIST 'PROG P1PCX X GL MODELIST
PVRL BODY PROGUNSF NLNVTHTBP))
(RETURN (COND ((NULL OARITHP) GONE2)
((CONS GONE2 (COND ((NULL (CAR PROGTYPE)) PKTYP)
((EQ (CAR PROGTYPE) (CADR PROGTYPE))
(CAR PROGTYPE))
(PKTYP))))))))
(COND (PVRL (CONS PVRL OPVRL)) (OPVRL))
MODELIST RNL BVARS T T 0 ARITHP KTYPE)
(P1SQE X)
(COND (PROGP (SETQ P1PSQ (LADD (LSUB X PVRL) P1PSQ))))))
(DEFUN P1GO (X)
(P1SQG X)
(COND ((ATOM (CADR X))
(AND (NOT #(SYMBOLP (CADR X)))
(SETQ X (LIST 'GO (P1TAG (CADR X)))))
#(PUSH (CADR X) GONE2)
X)
(T #(PUSH GOFOO GONE2)
(LIST 'GO (P1VN (CADR X))))))
(DEFUN P1RETURN (X)
(P1SQG X)
(COND ((OR (NULL (CDR X)) (NULL (CADR X)) (QNILP (CADR X)))
(SETQ PROGTYPE (P1TYPE-ADD PROGTYPE NIL))
(COND (ARITHP '((RETURN 'NIL))) ('(RETURN 'NIL))))
(((LAMBDA (T1 MODE UNSAFEP)
(SETQ T1 ((LAMBDA (ARITHP PNOB EFFS KTYPE)
(P1 (CADR X)))
T NIL NIL PKTYP))
(SETQ MODE (CDR T1) T1 (CAR T1))
(AND (NOT (ZEROP (P1TRESS T1)))
(SETQ P1PCX (ADD1 P1PCX)))
(SETQ PROGTYPE (P1TYPE-ADD PROGTYPE MODE))
(COND ((NULL (SETQ UNSAFEP (UNSAFEP T1)))
(SETQ UNSAFEP (AND (NOT (QNP T1)) (NOT #(SYMBOLP T1)) T)))
((SETQ PROGUNSF (COND ((ATOM T1)
(OR (MEMQ T1 PVRL) ;IF RETURNING A PROG NUMBER VAR
(SETQ UNSAFEP NIL)) ;THEN ALLOW NLNFINDCR BELOW
(ADD T1 PROGUNSF))
(T (AND (LAND T1 PROGUNSF)
(SETQ PROGUNSF (ADD PROGN PROGUNSF)))
(LADD T1 PROGUNSF))))))
(COND ((AND MODE PNOB UNSAFEP)
(SETQ CNT (+ CNT 2))
(AND (NOT PROGPNOB)
(SETQ PROGPNOB (NLNVFINDCR MODE 'PROG)))
(SETQ T1 (LIST 'SETQ PROGPNOB T1))))
(SETQ T1 (LIST 'RETURN T1))
(COND (ARITHP (CONS T1 NIL)) (T1)))
NIL NIL NIL))))
(DEFUN P1TAG (X)
((LAMBDA (TYPE)
(COND ((EQ TYPE 'SYMBOL) X)
((MEMQ TYPE '(FIXNUM FLONUM))
((LAMBDA (*NOPOINT BASE) (IMPLODE (EXPLODEC X))) T 10.))
(T (PDERR X |NOT ACCEPTABLE AS GO TAG|) GOFOO)))
(TYPEP X)))
(DEFUN P1PROG2 (XPR)
(DO ((TYPE) (T1) (T2) (OEFFS EFFS) (EFFS T) (OARITHP ARITHP) (ARITHP))
NIL
(SETQ T1 (P1 (CAR XPR)))
(COND ((NULL OEFFS)
(SETQ ARITHP OARITHP EFFS NIL)
(SETQ T2 (P1 (CADR XPR)))
(AND ARITHP (SETQ TYPE (CDR T2) T2 (CAR T2) ARITHP NIL))
(SETQ EFFS T))
(T (SETQ T2 (P1 (CADR XPR)))))
(SETQ T2 (CONS 'PROG2 (CONS T1 (CONS T2 (MAPCAR 'P1 (CDDR XPR))))))
(RETURN (COND ((NOT OARITHP) T2) ((CONS T2 TYPE))))))
(DEFUN P1PROGN (X FUN)
(SETQ X (CONS FUN (P1L X EFFS ARITHP KTYPE)))
(AND ARITHP
((LAMBDA (LL MODE)
(SETQ MODE (CDAR LL))
(RPLACA LL (CAAR LL))
(SETQ X (CONS X MODE)))
(LAST X) NIL))
X)
(DEFUN P1SETQ (X)
(PROG (VAR VAL LCP SPFL)
(SETQ LCP NIL)
(DO ((ZZ (CDR X) (CDDR ZZ)) (ARITHP)) ((NULL ZZ))
(COND ((NULL (CDR ZZ)) (RETURN (SETQ LCP NIL)))
((COND ((NOT #(SYMBOLP (CAR ZZ)))
(PDERR X |NON-SYMBOL FOR ASSIGNMENT IN SETQ|)
(SETQ VAR (GENSYM))
T)
((MEMQ (CAR ZZ) '(T NIL))
(PDERR X |DON'T SETQ T OR NIL|)
(SETQ VAR (COPYSYMBOL (CAR ZZ) NIL))
T))
(SETQ ZZ (CONS VAR (CDR ZZ)))))
(COND ((AND (NULL (CDDR ZZ))
(OR (EQ (CAR ZZ) (CADR ZZ))
(AND (NOT (ATOM (CADR ZZ)))
(EQ (CAADR ZZ) 'PROG2)
(EQ (CAR ZZ) (CADDR (CADR ZZ))))))
(SETQ X '(PROG2))
(SETQ LCP (LIST (COND ((NULL LCP) ''NIL)
((CONS 'SETQ (NREVERSE LCP))))
(P1 (CADR ZZ)))) ;(SETQ Y Y) => (PROG2 NIL Y)
(RETURN NIL))) ;(SETQ A B Y Y) => (PROG2 (SETQ A B) Y)
(SETQ VAR (COND ((CDR (ASSQ (CAR ZZ) RNL))) ;(SETQ Y (PROG2 C Y D)) ==>
((CAR ZZ)))) ; (PROG2 NIL (PROG2 C Y D))
;(SETQ A B Y (PROG2 C Y D)) =>
(P1SQV VAR) ; (PROG2 (SETQ A B) (PROG2 C Y D))
(SETQ VAL (P1BINDARG (SETQ SPFL (P1SPECIAL VAR)) VAR (CADR ZZ)))
(SETQ CNT (PLUS 2 CNT))
(AND (NOT SPFL) (RPLACD (ASSQ VAR LOCVARS) CNT))
(SETQ LCP (CONS VAL (CONS VAR LCP))))
(AND (NULL LCP) (PDERR X |WRONG NUMBER OF ARGS TO SETQ|))
(SETQ VAR (CADR LCP)) ;REGARDLESS OF CONDITION BELOW, THIS GETS THE NAME OF
(AND (NOT (EQ (CAR X) 'PROG2)) ;THE VARIABLE WHOSE VALUE IS BEING RETURNED
(SETQ LCP (NREVERSE LCP)))
(SETQ LCP (CONS (CAR X) LCP))
(RETURN (COND ((NOT ARITHP) LCP)
((CONS LCP (VARMODE VAR)))))))
(DEFUN P1SIGNP (X)
((LAMBDA (TEST ARG)
(COND ((NULL TEST) (PDERR X |BAD ARGS TO SIGNP|) ''NIL)
((NOT (MEMQ (CDR TEST) '(T NIL)))
(SETQ ARG (P1VAP ARG T))
(COND ((NULL (CDR ARG))
(LIST 'SIGNP (CAR TEST) (CAR ARG)))
(T (SETQ ARG (LIST (CDR TEST) (CAR ARG)))
(AND (MEMQ (CAR TEST) '(N GE LE))
(SETQ ARG (LIST 'NULL ARG)))
ARG)))
(T (P1 (LIST 'PROG2 ARG (CDR TEST))))))
(ASSQ ((LAMBDA (OBARRAY) (INTERN (CADR X))) SOBARRAY)
'((N . ZEROP) (E . ZEROP) (G . PLUSP) (LE . PLUSP)
(L . MINUSP) (GE . MINUSP) (- . NIL) (A . T)))
(CADDR X)))
(DEFUN P1SPECIAL (X)
(COND ((EQ X 'QUOTE) (DBARF NIL |CANT USE 'QUOTE' FOR A VARIABLE|))
(#(SPECIALP X) T)
((COND ((NOT (MEMQ X BVARS)))
(SPECIAL (NOT (GET X 'P1M-NOSPEC))))
(CKCFV X)
(PUTPROP X T 'SPECIAL)
(COND ((NULL SPECIAL)
#(WARN X |UNDECLARED - TAKEN AS SPECIAL|)
#(PUSH X P1SPECIALIZEDVS)
(COND ((REMPROP X 'OHOME)
((LAMBDA (Y) (AND Y (SETQ LOCVARS (DELQ Y LOCVARS))))
(ASSQ X LOCVARS))))))
T)
(T (RPLACD (COND ((ASSQ X LOCVARS)) ((BARF X |LOST LOCVAR - P1SPECIAL|)))
CNT)
NIL)))
(DEFUN P1SPECIALIZEDVS NIL
(DO ((LL P1SPECIALIZEDVS (CDR LL)) (TEM) (Z))
((NULL LL)
(AND Z (DBARF Z |THESE VARIABLES MUST BE DECLARED SPECIAL BY USER/
THE CODE FOR THIS FUNCTION WILL PROBABLY NOT BE CORRECT.|))
(SETQ P1SPECIALIZEDVS NIL)
Z)
(COND ((SETQ TEM (ASSQ (CAR LL) LOCVARS))
(SETQ LOCVARS (DELQ TEM LOCVARS))
(COND ((SETQ TEM (ASSQ (CAR LL) RNL))
(SETQ RNL (DELQ TEM RNL)
SPECVARS #(PUSH (CDR TEM) SPECVARS))
(AND (SETQ TEM (ASSQ (CDR TEM) LOCVARS))
(SETQ LOCVARS (DELQ TEM LOCVARS)))))
#(PUSH (CAR LL) Z)))))
(DEFUN P1SQE (L)
; EXTEND SETQ VARS FROM INNER PROG,COND, OR LAMBDA TO
; THE OUTER COND S AND ANY OUTER LAMBDA
(COND (L (COND (CONDP (SETQ P1CSQ (LADD L P1CSQ))))
(COND (LMBP (SETQ P1LSQ (LADD (LSUB L P1LL) P1LSQ))))))
NIL)
(DEFUN P1SQG (Z)
(COND ((NOT PROGP) (PDERR Z |GO OR RETURN NOT IN PROG|)))
(SETQ PRSSL T)
(P1SQV GOFOO))
(DEFUN P1SQV (Y)
(COND (CONDP (SETQ P1CSQ (ADD Y P1CSQ))))
(COND ((AND LMBP (NOT (MEMQ Y P1LL))) (SETQ P1LSQ (ADD Y P1LSQ))))
(COND ((AND PROGP (NOT (EQ Y GOFOO)) (NOT (MEMQ Y PVRL)))
(SETQ P1PSQ (ADD Y P1PSQ)))))
;;; CONDTYPE AND PROGTYPE HAVE A VERY RIGID FORMAT:
;;; NIL
;;; (NIL)
;;; (FIXNUM FIXNUM)
;;; (FLONUM FLONUM)
;;; (FIXNUM FLONUM)
;;; (NIL FIXNUM)
;;; (NIL FLONUM)
;;; (NIL FIXNUM FLONUM)
(DEFUN P1TYPE-ADD (TYPEL TYP)
(COND ((NULL TYPEL)
(SETQ TYPEL (COND ((EQ TYP 'FIXNUM) '(FIXNUM FIXNUM))
((EQ TYP 'FLONUM) '(FLONUM FLONUM))
('(NIL)))))
((CDDR TYPEL))
((NULL (CAR TYPEL))
(COND ((NULL TYP))
((CDR TYPEL) (AND (NOT (EQ TYP (CADR TYPEL)))
(SETQ TYPEL '(NIL FIXNUM FLONUM))))
(T (SETQ TYPEL (COND ((EQ TYP 'FIXNUM) '(NIL FIXNUM))
('(NIL FLONUM)))))))
((NOT (EQ (CAR TYPEL) (CADR TYPEL)))
(AND (NULL TYP) (SETQ TYPEL '(NIL FIXNUM FLONUM))))
(TYP (AND (NOT (EQ (CAR TYPEL) TYP)) (SETQ TYPEL '(FIXNUM FLONUM))))
(T (SETQ TYPEL (COND ((EQ (CADR TYPEL) 'FIXNUM) '(NIL FIXNUM))
('(NIL FLONUM))))))
TYPEL)
(DEFUN P1TRESS (F) ;F HAS ALREADY BEEN P1'D
(COND ((OR (ATOM F)
(MEMQ (CAR F) '(QUOTE FUNCTION *FUNCTION EQ GO RETURN))
(AND (GET (CAR F) CARCDR)
(NOT (AND (NOT (ATOM (CAR F))) (EQ (CAAR F) CARCDR) (< (LENGTH (CDAR F)) 4)))))
0)
((MEMQ (CAR F) '(RPLACD RPLACA))
(COND ((AND (NOT (ZEROP (P1TRESS (CADR F))))
(ZEROP (P1TRESS (CADDR F))))
1)
(0)))
((MEMQ (CAR F) '(MEMQ SETQ)) (COND ((NOT (ZEROP (P1TRESS (CADDR F)))) 1) (0)))
((MEMQ (CAR F) '(COND PROG)) (CADR F))
((EQ (CAAR F) 'LAMBDA) (CADAR F))
((AND (EQ (CAR F) 'NULL) (P1BOOL1ABLE (CADR F))) 0)
((MEMQ (CAR F) '(AND OR)) (BARF F |AND-OR LOSS - P1TRESS|))
(1)))
(DEFUN P1VAP (XPR OPNOB) ;P1 FOR VALUE, ARITHMETICS, AND PNOB SUPPLIED
((LAMBDA (ARITHP PNOB EFFS KTYPE) (P1 XPR)) T OPNOB NIL NIL))
(DEFUN P1VN (XPR) ;P1 FOR VALUE, NO ARITHMETICS
((LAMBDA (ARITHP EFFS KTYPE) (P1 XPR)) NIL NIL NIL))
(DEFUN P1VAL (X IPN)
((LAMBDA (Y)
(COND ((EQ Y 'SYMBOL)
(COND ((OR IPN (MEMQ X '(T NIL)) #(SPECIALP X)) NIL)
(T (AND (SETQ Y (ASSQ X RNL))
(SETQ X (CDR Y)))
(COND ((MEMQ X BVARS))
(T (P1SPECIAL X) NIL)))))
((EQ Y 'LIST)
(NOT (MEMQ (CAR X) '(QUOTE FUNCTION))))))
(TYPEP X)))
(DEFUN P1QLIFY (X)
(P1VN (COND ((NOT (P1VAL X NIL)) X)
((CONS 'LIST (CONS ''QUOTE (LIST X)))))))
(COMMENT NLNVTHTBP VARIABLE HACKERY)
(DEFUN NLNVASG (VARS)
(DO ((X NLNVS (CDR X)) (FL))
((NULL X) (AND FL (SETQ NLNVS (DELQ NIL NLNVS))))
(COND ((MEMQ (CAAR X) VARS)
#(PUSH (CDAR X) NLNVTHTBP)
(PUTPROP (CDAR X) NIL 'OHOME)
#(PUSH (CONS (CDAR X) CNT) LOCVARS)
(SETQ FL T)
(RPLACA X NIL))
((AND (NOT (MEMQ (CAAR X) BVARS))
(NOT (MEMQ (CAAR X) P1LLCEK))
(NOT (MEMQ (CAAR X) ROSENCEK)))
(WARN (CAR X) |SHOW JONL - NLNVASG|)))))
(DEFUN NLNVFINDCR (MODE TYPE)
(NLNVCR (COND ((AND (NOT (EQ PNOB T)) PNOB))
((COND ((NULL PNOB) NIL)
((AND (NOT (EQ TYPE 'PROG)) (CAR (OR P1LL PVRL))))
((CAAR OPVRL))))
((CAR #(PUSH (GENSYM) ROSENCEK))))
MODE))
(DEFUN NLNVCR (VAR MODE)
((LAMBDA (NAME)
(PUTPROP NAME MODE 'NUMVAR)
#(PUSH (CONS VAR NAME) NLNVS)
NAME)
(INTERN (GENSYM))))
(DEFUN NLNVEX (VAR ITEM) ;CALLED ONLY BY P1BINDARG
(COND ((AND ITEM (NOT (EQ ITEM T))) ;ONLY CALLED WHERE ITEM IS RESULT OF UNSAFEP
(SETQ UNSFLST (ADD VAR UNSFLST))
(COND ((ATOM ITEM) (NLNV1 VAR ITEM NLNVS))
(T (MAPC '(LAMBDA (OLDVAR) (NLNV1 VAR OLDVAR NLNVS)) ITEM))))))
(DEFUN NLNV1 (NEWVAR OLDVAR SHEE-IT)
(AND (MEMQ NEWVAR (MEMQ OLDVAR BVARS))
(DO ((Y SHEE-IT (CDR Y)) (ITEM))
((NULL Y))
(COND ((EQ (CAAR Y) OLDVAR)
(PUTPROP OLDVAR NEWVAR 'NLNVS)
(RPLACA (CAR Y) NEWVAR))
((EQ (CAAR Y) (SETQ ITEM (GET OLDVAR 'NLNVS)))
(NLNV1 NEWVAR ITEM Y))))))
(COMMENT SOME TYPE ANALYZERS USED BY PHASE 1)
;BASICALLY, P1 TYPE ANALYZERS, WHERE XPR HAS NOT YET BEEN P1'D
(DEFUN NUMTYP (XPR NUMBERP)
(SETQ XPR (NUMTYPEP XPR NUMBERP))
(AND (MEMQ (CDR XPR) '(FIXNUM FLONUM)) XPR))
(DEFUN NUMTYPEP (XPR NUMBERP) ;RETURNS FORM ACTUALLY FOUND TO BE OF NUMERIC TYPE [EXCEPT FOR
;A NUMERIC CONSTANT, IN WHICH CASE 1 OR 1.0 IS USED] CONS'D TO TYPE
((LAMBDA (TYPE)
(COND ((EQ TYPE 'FIXNUM) '(1 . FIXNUM))
((EQ TYPE 'FLONUM) '(1.0 . FLONUM))
((EQ TYPE 'SYMBOL) (AND (SETQ TYPE (VARMODE XPR)) (CONS XPR TYPE)))
((NOT (EQ TYPE 'LIST)) NIL)
((EQ (SETQ TYPE (TYPEP (CAR XPR))) 'LIST)
(COND ((EQ (CAAR XPR) 'LAMBDA) ;### THIS FAILS WHEN RET VAL DEPENDS ON
(NUMTYPEP (CAR (LAST (CDDAR XPR))) NUMBERP)) ;LOCAL VARS AND DECLARATIONS
((EQ (CAAR XPR) COMP)
(WARN XPR |LET JONL SEE THIS CODE NUMTYPEP|)
(AND (MEMQ (CADAR XPR) '(FIXNUM FLONUM))
(CONS XPR (CADAR XPR))))))
((NOT (EQ TYPE 'SYMBOL)) NIL)
((EQ (CAR XPR) 'SETQ)
(SETQ XPR (NX2LAST (CDR XPR)))
(AND (SETQ TYPE (NUMERVARP XPR)) (CONS XPR TYPE)))
((EQ (CAR XPR) 'QUOTE)
(COND ((EQ (SETQ XPR (TYPEP (CADR XPR))) 'FIXNUM) '(1 . FIXNUM))
((EQ XPR 'FLONUM) '(1.0 .FLONUM))))
((EQ (CAR XPR) 'PROG2) (NUMTYPEP (CADDR XPR) NUMBERP))
((MEMQ (CAR XPR) '(PROGN PROGV))
(NUMTYPEP (CAR (LAST (CDR XPR))) NUMBERP))
((EQ (CAR XPR) 'DO) ;### SEE THE CAVEAT ON LAMBDAS ABOVE
(AND (NOT (ATOM (CADR XPR))) ;### ALSO FAILS ON PROGS TOO
(SETQ TYPE (CAR (LAST (CADDR XPR))))
(OR (ATOM TYPE) (NOT (QNILP TYPE)))
(NUMTYPEP TYPE NUMBERP)))
((EQ (CAR XPR) 'COND)
(COND (NUMBERP (DO ((Y (CDR XPR) (CDR Y)))
((NULL Y) (SETQ TYPE NIL))
(AND (SETQ TYPE (CDR (NUMTYP (CAR (LAST (CAR Y))) T)))
(RETURN NIL))))
(T (SETQ TYPE NIL)
(DO ((Y (CDR XPR) (CDR Y)) (FL))
((NULL Y))
(COND ((NULL (SETQ FL (CDR (NUMTYPEP (CAR (LAST (CAR Y))) NIL))))
(RETURN (SETQ TYPE NIL)))
((NULL TYPE) (SETQ TYPE FL))
((NOT (MEMQ TYPE '(FIXNUM FLONUM))))
((EQ TYPE FL))
(T (SETQ TYPE T))))))
(AND TYPE (CONS XPR TYPE)))
((SETQ TYPE (NUMFUNP XPR T)) (CONS XPR TYPE))
((AND (SETQ TYPE (P1MACROGET XPR))
(NOT (EQ (CAR TYPE) NULFU))
(NOT (EQ (CAR TYPE) GOFOO)))
(NUMTYPEP (CAR TYPE) NUMBERP))))
(TYPEP XPR)))
;;;A SUBROUTINE FOR P1CJ-NUMVALP AND NUMTYPEP - ARG MUST BE NONATOMIC WITH ATOMIC CAR
(DEFUN NUMFUNP (FORM P1P)
(COND ((MEMQ (CAR FORM) '(ARRAYCALL LSUBRCALL SUBRCALL))
(AND (MEMQ (CADR FORM) '(FIXNUM FLONUM)) (CADR FORM)))
(((LAMBDA (PROP)
(COND ((NULL PROP)
(AND (SETQ PROP (FUNMODE (COND ((SETQ PROP (ASSQ (CAR FORM) RNL)) (CDR PROP))
((CAR FORM)))))
(CADR PROP)))
((OR (EQ (CAR PROP) 'ARITHP) (EQ (CAR PROP) 'NUMFUN)) (CADADR PROP))
((EQ (CAR PROP) 'NUMBERP)
(COND (CLOSED NIL)
((EQ (CADR PROP) 'NOTYPE) NIL)
((OR FIXSW (EQ (CAR FORM) 'HAULONG)) 'FIXNUM)
((OR FLOSW (EQ (CAR FORM) 'FLOAT)) 'FLONUM)
((NOT P1P)
(COND ((OR (EQ (CAR FORM) 'FIX) (NULL (CADR FORM)))
NIL) ;FOR NUMVALP, WE DONT CARE TO KNOW THE "T" TYPES
((MEMQ (CADR FORM) '(FIXNUM FLONUM))
(CADR FORM))
((AND (GET (CAR FORM) 'CONTAGIOUS)
(MEMQ 'FLONUM (CADR FORM)))
'FLONUM)))
((NOT (GET (CAR FORM) 'CONTAGIOUS))
(SETQ PROP (CDR (NUMTYPEP (CADR FORM) T)))
(COND ((AND (EQ (CAR FORM) 'FIX)
(NOT (EQ PROP 'FIXNUM)))
T)
(PROP)))
((DO ((Y (CDR FORM) (CDR Y))
(ANS 'FIXNUM))
((NULL Y) ANS)
(SETQ PROP (CDR (NUMTYPEP (CAR Y) T)))
(COND ((EQ PROP 'FLONUM) (RETURN 'FLONUM))
((NOT (EQ PROP 'FIXNUM)) (SETQ ANS T)))))))))
(GETL (CAR FORM) '(ARITHP NUMFUN NUMBERP))))))
(DEFUN NUMERVARP (VAR) (AND #(SYMBOLP VAR) (VARMODE VAR)))
(DEFUN NOTNUMP (X) ;PHASE2 ANALYZER FOR SOMETHING PROVEABLY NOT A FIXNUM OR FLONUM
(COND ((ATOM X) NIL)
((NOT (ATOM (CAR X)))
(COND ((EQ (CAAR X) '*MAP))
((EQ (CAAR X) 'LAMBDA) (NOTNUMP (CADDDR (CDDAR X))))))
((EQ (CAR X) 'QUOTE) (OR (NOT (NUMBERP (CADR X))) (BIGP (CADR X))))
((EQ (CAR X) 'PROG2) (NOTNUMP (CADDR X)))
((OR (EQ (CAR X) 'PROGN)
(EQ (CAR X) PROGN)
(EQ (CAR X) 'PROGV)
(EQ (CAR X) 'IOG))
(NOTNUMP (CAR (LAST (CDR X)))))
(((LAMBDA (FL)
(COND ((NULL FL) NIL)
((EQ (CAR FL) 'NOTNUMP))
((EQ (CAR FL) 'NUMBERP) (EQ (CADR FL) 'NOTYPE))
((EQ (CAR FL) 'ARITHP) (NULL (CADADR FL)))
((EQ (CAR FL) 'FSUBR)
(COND ((MEMQ (CAR X)
'(FASLOAD STORE STATUS SSTATUS SETQ GO THROW ERR COND PROG))
NIL)
((MEMQ (CAR X) '(ARRAYCALL SUBRCALL LSUBRCALL))
(NOT (MEMQ (CADR X) '(FIXNUM FLONUM))))
(T)))
((AND (EQ (CAR FL) 'MACRO)
(SETQ FL (P1MACROGET X))
(NOT (EQ (CAR FL) NULFU))
(NOT (EQ (CAR FL) GOFOO)))
(NOTNUMP (CAR FL)))))
(GETL (CAR X) '(NOTNUMP NUMBERP ARITHP FSUBR MACRO))))))
(DEFUN SAMETYPES (TYPEL) ;WILL TAKE A TYPES LIST, E.G.
((LAMBDA (TYPE) ;(FIXNUM NIL FLONUM NIL FLONUM)
(DO L (CDR TYPEL) (CDR L) ;AND CONVERT IT TO AN ATOM [ONE OF
(COND ((NULL L) (SETQ TYPEL TYPE) T) ;NIL, FIXNUM, FLONUM] IF ALL TYPES
((NOT (EQ TYPE (CAR L))))))) ;ARE THE SAME
(CAR TYPEL))
TYPEL)
(DEFUN UNSAFEP (XPR) ;PHASE2 ANALYZER, FOR SOMETHING THAT MIGHT BE A PDL NUMBER
(COND ((ATOM XPR)
(AND (COND ((MEMQ XPR UNSFLST))
((NOT #(SYMBOLP XPR)) NIL)
((NULL (VARMODE XPR)) NIL)
((NOT #(SPECIALP XPR))))
XPR))
((NOT (ATOM (CAR XPR)))
(AND (EQ (CAAR XPR) 'LAMBDA) (CADDDR (CDDDDR (CAR XPR)))))
((EQ (CAR XPR) 'PROG) (CADDDR (CDDDDR XPR)))
((EQ (CAR XPR) 'COND) (CADDDR XPR))
((EQ (CAR XPR) 'SETQ) (UNSAFEP (NX2LAST (CDR XPR))))
((EQ (CAR XPR) 'PROG2) (UNSAFEP (CADDR XPR)))
((OR (EQ (CAR XPR) 'PROGN) (EQ (CAR XPR) PROGN))
(UNSAFEP (CAR (LAST (CDR XPR)))))
((EQ (CAR XPR) 'ARG) ARGLOC)))
(COMMENT SOME P1 CHECKING FUNCTIONS)
(DEFUN UUVP (L LL F)
(COND ((SETQ L (MAPCAN '(LAMBDA (X) (AND
(SETQ X (ASSQ X LOCVARS))
(= (CDR X) 0)
(LIST (COND ((ASSOCR (CAR X) RNL))((CAR X))))))
L))
(MSOUT L
(COND ((EQ F 'PROG) (FUNCTION (LAMBDA () (PRINC '|UNUSED PROG VARIABLES|))))
(T (FUNCTION (LAMBDA () (PRINC '|UNUSED LAMBDA VARIABLES|)))))
'WARN
NIL
NIL)
(SET LL (LSUB (SYMEVAL LL) L)))))
(DEFUN CKARGS (NAME M)
((LAMBDA (ARGS)
(COND ((NULL ARGS) (ARGS NAME (CONS NIL M)))
((AND (NULL (CAR ARGS)) (= (CDR ARGS) M)))
(#(WARN NAME |HAS BEEN PREVIOUSLY USED WITH INCORRECT NUMBER OF ARGS/
DISCOVERED WHILE |))))
(ARGS NAME)))
(DEFUN CKCFV (X)
(COND (SPECIAL)
(CFVFL (MAPC '(LAMBDA (Y) (AND (OR (MEMQ X (CAR Y)) (ASSQ X (CDR Y)))
(THROW 'CFVFL CFVFL)))
CFVFL)
NIL)
((AND P1GFY (OR (MEMQ X BVARS) (ASSQ X RNL)))
(DBARF X |USED FREE INSIDE A LAMBDA FORM. MUST BE DECLARED SPECIAL|))))
(DEFUN WRNTYP (NAME)
#(WARN NAME |HAS BEEN INCORRECTLY DECLARED *EXPR OR *FEXPR/
DISCOVERED WHILE |)
(LREMPROP NAME '(*EXPR *FEXPR *LEXPR ARGS)))
(COMMENT FUNCTIONS TO RUN DECLARATIONS)
;;;HOW TO DISOWN FROM A ↑H BREAK
(DEFUN DISOWN NIL (SETQ DISOWNED T) (GIVUPTTY) (THROW NIL BREAK))
(DEFUN DISOWNED (X) (SETQ DISOWNED X))
(DEFUN FASL (X) (SETQ FASL X))
(DEFUN NOLAP (X) (SETQ NOLAP X))
(DEFUN ASSEMBLE (X) (SETQ ASSEMBLE X))
(DEFUN NOARGS (X) (SETQ NOARGS X))
(DEFUN SYMBOLS (X) (SETQ SYMBOLS X))
(DEFUN MACROS (X) (SETQ MACROS X))
(DEFUN MAPEX (X) (SETQ MAPEX X))
(DEFUN UNFASLCOMMENTS (X) (SETQ UNFASLCOMMENTS X))
(DEFUN MESSIOC FEXPR (L) (SETQ MESSIOC L))
(DEFUN EXPR-HASH (X) (SETQ EXPR-HASH X))
(DEFUN RECOMPL (X) (SETQ RECOMPL (APPEND X RECOMPL)) 'RECOMPL)
(DEFUN EOC-EVAL (X) (SETQ EOC-EVAL (APPEND EOC-EVAL X NIL)) 'EOC-EVAL)
(DEFUN GENPREFIX FEXPR (X) (SETQ GENPREFIX (EXPLODEC (CAR X))))
(DEFUN CLOSED (X) (SETQ CLOSED X))
(DEFUN MUZZLED (X) (SETQ MUZZLED X))
(DEFUN FIXSW (X) (SETQ FIXSW X))
(DEFUN FLOSW (X) (SETQ FLOSW X))
(DEFUN /@DEFINE FEXPR (X) X T)
(DEFUN *DECLARE (L PROP)
(MAPC '(LAMBDA (X)
(COND ((AND (NOT (EQ PROP 'SPECIAL)) (SYSP X))
(COND ((OR (GET X 'CARCDR)
(AND (GET X 'FSUBR) (NOT (EQ X 'EDIT)) (NOT (EQ PROP '*FEXPR)))
(AND (GET X 'ACS)
((LAMBDA (CHAR) (MEMQ CHAR '(* /.))) (GETCHAR X 1)))
(MEMQ X '(LIST CONS XCONS RPLACA RPLACD SET EQ EQUAL NULL NOT
ZEROP PROG2 PROGN ASSQ MEMQ BOOLE PRINC PRIN1 PRINT
READ READCH TYI TYO PLIST PUTPROP REMPROP)))
(DBARF (CONS PROP L) |THIS DECLARATION WONT WORK|))
(T (LREMPROP X '(ACS ARITHP NUMBERP NOTNUMP))
(PUTPROP X T PROP))))
((AND (EQ PROP 'SPECIAL)
(EQ COMPILER-STATE 'COMPILE)
(ASSQ X RNL) (SETQ X (CDR (ASSQ X RNL)))
(QUOTE NIL)))
((PUTPROP X T PROP)))
NIL)
L))
(DEFUN SPECIAL FEXPR (X) (*DECLARE X 'SPECIAL))
(DEFUN UNSPECIAL FEXPR (L)
(COND ((EQ COMPILER-STATE 'COMPILE) (PDERR (CONS 'UNSPECIAL L) |CAN'T LOCALLY UNSPECIALIZE|))
(T (REMPROPL 'SPECIAL L))))
(DEFUN *EXPR FEXPR (X) (*DECLARE X '*EXPR))
(DEFUN *FEXPR FEXPR (X) (*DECLARE X '*FEXPR))
(DEFUN *LEXPR FEXPR (X) (*DECLARE X '*LEXPR))
(DEFUN FIXNUM FEXPR (X) (NUMPROP X 'FIXNUM))
(DEFUN FLONUM FEXPR (X) (NUMPROP X 'FLONUM))
(DEFUN NOTYPE FEXPR (DECLS) (NUMPROP DECLS NIL))
(DEFUN NUMPROP (DECLS TYP)
(PROG (TEMP PROP TOPFN)
(MAPC '(LAMBDA (DECL)
(COND ((ATOM DECL)
(AND (EQ COMPILER-STATE 'COMPILE)
(SETQ TEMP (ASSQ DECL RNL))
(SETQ DECL (CDR TEMP)))
(COND ((NULL TYP) (REMPROP DECL 'NUMVAR))
((AND (SETQ TEMP (GET DECL 'NUMVAR))
(NOT (EQUAL TEMP TYP)))
(WARN DECL |VARIABLE BEING REDECLARED|))
(T (PUTPROP DECL TYP 'NUMVAR))))
(T (SETQ PROP (NMPSUBST (CDR DECL) TYP))
(AND (SETQ TEMP (GET (CAR DECL) 'NUMFUN))
(NOT (EQUAL PROP TEMP))
(WARN DECL |FUNCTION BEING REDECLARED|))
(PUTPROP (CAR DECL) PROP 'NUMFUN))))
DECLS)))
(DEFUN NMPSUBST (LIST TYP)
(AND (DO X LIST (CDR X) (NULL X)
(AND (NOT (MEMQ (CAR X) '(FIXNUM FLONUM NIL))) (RETURN T)))
(SETQ LIST
(MAPCAR '(LAMBDA (X)
(COND ((MEMQ X '(FIXNUM FLONUM NIL)) X)
((EQ X 'NOTYPE) NIL)
(((LAMBDA (TYP)
(COND ((MEMQ TYP '(FIXNUM FLONUM)) TYP)
(T (PDERR (LIST X '-IN- (LIST TYP LIST))
|INCORRECT ARG FOR NUMBER DECLARATION|)
NIL)))
(TYPEP X)))))
LIST)))
(CONS (REVERSE LIST) (CONS (COND ((NOT (MEMQ TYP '(FIXNUM FLONUM))) NIL) (TYP)) LIST)))
(DEFUN LCLDECLARE (L)
(MAPC '(LAMBDA (DATA)
(DO ((X (CDR DATA) (CDR X)) (TEMP) (ATOMP)) ;FIX UP FOR RENAMINGS OF VARIALBES
((NULL X))
(COND ((SETQ TEMP (ASSQ (COND ((SETQ ATOMP (ATOM (CAR X)))
(CAR X))
((CAAR X)))
RNL))
(RPLACA (COND (ATOMP X) ((CAR X))) (CDR TEMP)))))
(AND (COND ((EQ (CAR DATA) 'SPECIAL))
((MEMQ (CAR DATA) '(FIXNUM FLONUM NOTYPE)))
(T (PDERR DATA |ILLEGAL LOCAL DECLARATION|) NIL))
(MAPC '(LAMBDA (X)
(COND ((ATOM X)
(COND ((MEMQ X BVARS)
(PDERR DATA |LOCAL DECLARATION OCCURS TOO LATE IN FUNCTION|)
NIL)
((EQ (CAR DATA) 'SPECIAL)
(REMPROP X 'OHOME)
(AND (NOT (GET X 'SPECIAL)) #(PUSH X SPECVARS)))
((AND (GET X 'NUMVAR) (EQ (GET X 'NUMVAR) (CAR DATA))))
(#(PUSH (CONS X (COND ((EQ (CAR DATA) 'NOTYPE) NIL)
((CAR DATA))))
MODELIST))))
((VARMODE (CAR X)) (PDERR DATA |CANT LOCALLY REDECLARE FUNCTION|))
((AND (NULL (CDR X)) (EQ (CAR DATA) 'NOTYPE)))
(#(PUSH (CONS (LIST (CAR X)) (NMPSUBST (CDR X) (CAR DATA))) MODELIST))))
(CDR DATA))))
(CDAR L)))
(DEFUN NEWIO (X)
((LAMBDA (VL DATA)
(COND ((AND (NOT NIOP/|) VL)
(MAPC 'ARGS '(LISTEN READLINE READ TYI TYIPEEK CURSORPOS OPEN)
'((0 . 1) (0 . 2) (0 . 2) (0 . 2) (0 . 3) (0 . 3) (0 . 4)))
(MAPC '(LAMBDA (X) (ARGS X '(1 . 2)))
'(LINEL PAGEL CHARPOS LINENUM PAGENUM EOFFN
ENDPAGEFN FILEPOS RUBOUT))
(SPECIAL ECHOFILES MSGFILES INFILE INSTACK OUTFILES
IO-LOSSAGE CLI-MESSAGE MAR-BREAK TTY-RETURN
SYS-DEATH MACHINE-ERROR TYO TYI)))
(MAPC '(LAMBDA (PROP)
(SETQ DATA (CAR PROP))
(MAPC '(LAMBDA (X)
(COND ((NULL (CDR DATA)))
(VL (REMPROP X (CDR DATA)))
(NIOP/| (PUTPROP X T (CDR DATA))))
(COND ((NULL VL) (REMPROP X (CAR DATA)))
((NOT NIOP/|) (PUTPROP X T (CAR DATA)))))
(CDR PROP)))
'(((*LEXPR . *EXPR) PRINT PRIN1 PRINC TYO TERPRI LISTEN)
((*LEXPR) OPEN LINEL READLINE ENDPAGEFN EOFFN PAGEL CHARPOS
LINENUM PAGENUM RUBOUT FILEPOS)
((*FEXPR) INCLUDE)
((*EXPR) IN INPUSH OUT TRUENAME SHORTNAMESTRING NAMESTRING NAMELIST
DEFAULTF PROBEF LOAD FORCE-OUTPUT CLEAR-OUTPUT CLEAR-INPUT
CLOSE DELETEF RENAMEF MERGEF FASLP)))
(FIXNUM (IN) (LINEL) (PAGEL) (CHARPOS) (LINENUM) (PAGENUM))
VL)
X NIL))
(DEFUN ARRAY* FEXPR (LIST) (MAPC 'AR*1 LIST))
(DEFUN AR*1 (X)
(PROG (TYPE NAME FL N Y)
(AND (OR (ATOM X)
(NOT (MEMQ (CAR X) '(FIXNUM FLONUM NOTYPE))))
(GO BF))
(SETQ TYPE (CAR X) Y (CDR X))
A (AND (NULL Y) (RETURN NIL))
(COND ((NOT (ATOM (CAR Y)))
(SETQ NAME (CAAR Y) N (LENGTH (CDAR Y)) FL (CAR Y))
(DO Z (CDR FL) (CDR Z) (NULL Z)
(COND ((FIXP (CAR Z)))
((AND (QNP (CAR Z)) (FIXP (CADAR Z)))
(RPLACA Z (CADAR Z)))
(T (RPLACA Z NIL)))))
((NOT (NUMBERP (CADR Y))) (GO BF))
(T (SETQ NAME (CAR Y) N (CADR Y) FL (LIST NAME) Y (CDR Y))))
(AND (OR (LREMPROP NAME '(*EXPR *LEXPR *FEXPR))
(AND (REMPROP NAME 'NUMFUN) (NOT (GET NAME '*ARRAY))))
(WARN NAME |FUNCTION BEING RE-DECLARED AS AN ARRAY|))
(COND ((GET NAME '*ARRAY)
#(WARN NAME |ARRAY RE-DECLARED|)
(REMPROP NAME 'NUMFUN)))
(PUTPROP NAME FL '*ARRAY)
(PUTPROP NAME
(CONS NIL (CONS (COND ((NOT (EQ TYPE 'NOTYPE)) TYPE))
(NCDR '(FIXNUM FIXNUM FIXNUM
FIXNUM FIXNUM FIXNUM FIXNUM)
(- 7 N))))
'NUMFUN)
(SETQ Y (CDR Y))
(GO A)
BF (PDERR X |BAD ARRAY DCL|)))
(COMMENT FILE-TRANSDUCERS)
(DEFUN CMP1 NIL
;TRANSDUCE A FILE COMPILE ING THOSE SEXP S WHICH TRY TO DEFINE FUNCTION S
((LAMBDA (SYMBOLS READTABLE OBARRAY)
(PROG (X DECTB FL FORM IRASLOSS PRATTSTACK FFVL)
(SETQ IRASLOSS (SETQ DECTB '((*FEXPR . FEXPR) (*EXPR . EXPR) (*LEXPR .EXPR))))
(AND RECOMPL
(MAP '(LAMBDA (L) (AND (NOT (EQ (CAR L) (SETQ X (INTERN (CAR L)))))
(RPLACA L X)))
RECOMPL))
A (COND (PRATTSTACK (SETQ FORM (CAR PRATTSTACK) PRATTSTACK (CDR PRATTSTACK)))
((EQ GOFOO (SETQ FORM (COND (READ (FUNCALL READ GOFOO))
(NIOP/| (READ GOFOO))
((= (TYIPEEK T) 3) GOFOO)
((READ)))))
(AND FASLPUSH LAPLL (FASLIFY (NREVERSE (PROG2 NIL LAPLL (SETQ LAPLL NIL))) 'LIST))
(RETURN T)))
(SETQ CH FORM)
B (COND ((ATOM FORM)
(COUTPUT FORM)
(AND (NOT FASLPUSH) (PROG2 (COUTPUT NULFU) (COUTPUT GOFOO)))
(GO A))
((NOT (EQ (CAR FORM) 'DEFUN))
(AND (EQ (CAR FORM) 'DEFPROP) (NOT (ATOM (CADR FORM))) (GO GH)))
((OR (NULL (CDR FORM))
(NULL (CDDR FORM))
(NULL (CDDDR FORM)))
(GO GH))
((MEMQ (CADR FORM) '(FEXPR EXPR MACRO))
(AND (OR (NULL (CDDDDR FORM))
(NOT (MEMQ (TYPEP (CADDR FORM)) '(SYMBOL LIST))))
(GO GH))
(SETQ FORM (LIST 'DEFPROP (CADDR FORM)
(CONS 'LAMBDA (CDDDR FORM)) (CADR FORM))))
((MEMQ (CADDR FORM) '(FEXPR EXPR MACRO))
(AND (OR (NULL (CDDDDR FORM))
(NOT (MEMQ (TYPEP (CADR FORM)) '(SYMBOL LIST))))
(GO GH))
(SETQ FORM (LIST 'DEFPROP (CADR FORM)
(CONS 'LAMBDA (CDDDR FORM)) (CADDR FORM))))
((SETQ FORM (LIST 'DEFPROP (CADR FORM) (CONS 'LAMBDA (CDDR FORM)) 'EXPR))))
(COND ((EQ (CAR FORM) 'DEFPROP)
(COND ((OR (NULL (CDR FORM))
(NULL (CDDR FORM))
(NULL (CDDDR FORM))
(CDDDDR FORM))
(WARN FORM |NOT LEGAL DEFPROP FORM| 4 4)
(SETQ LAP-INSIGNIF NIL)
(COUTPUT (LIST 'QUOTE FORM)))
((EQ (SETQ FL (CADDDR FORM)) 'MACRO)
(AND MACROS (PROG2 (COUTPUT FORM) (SETQ LAP-INSIGNIF NIL)))
(COND ((GETL (CADR FORM)
'(EXPR FEXPR SUBR FSUBR LSUBR *FEXPR *EXPR *LEXPR))
(SETQ MACROLIST (CONS (CONS (CADR FORM)
(CADDR FORM))
MACROLIST)))
(T (EVAL FORM))))
((PROG2 (SETQ CH (CADR FORM) X (COND ((ATOM CH) CH) ((CAR CH))))
(AND RECOMPL (NOT (MEMQ X RECOMPL)))))
((ASSQ FL INDICLIST)
(SETQ UNDFUNS (DELQ X UNDFUNS))
(AND (ASSQ X FFVL) (GO F))
(SETQ LAP-INSIGNIF NIL)
(COND ((NOT (ATOM (CADDR FORM)))
(SETQ CFVFL T)
(COND ((NOT (ATOM CH))
(COND ((NULL (CDDR CH))
(COUTPUT (LIST 'DEFPROP
(CAR CH)
(SETQ X (MAKNAM (NCONC (EXPLODEC (CAR CH))
(LIST '/ )
(EXPLODEC (CADR CH)))))
(CADR CH))))
(T (SETQ CFVFL NIL)))))
(AND EXPR-HASH
CFVFL
(COUTPUT (LIST 'DEFPROP
X
(SXHASH (CADDR FORM))
'EXPR-HASH)))
(SETQ CFVFL NIL)
((LAMBDA (COMPILER-STATE ↑W ↑R)
(COMPILE CH FL (CADDR FORM) NIL NIL)
(COND (TTYNOTES
(SETQ ↑W NIL ↑R NIL)
(CMSGINDENT 0)
(PRIN1 CH)
(TYO 32.)
(PRINC 'COMPILED)))
(SETQ ↑W (SETQ ↑R T))
(COND (FASLPUSH
(FASLIFY (NREVERSE (PROG2 NIL LAPLL (SETQ LAPLL NIL)))
'LIST))
(T (TYO 12.)))
(COND (TTYNOTES
(SETQ ↑W NIL ↑R NIL)
(COND (FASLPUSH (PRINC '| AND ASSEMBLED |))
(T (TYO 32.))))))
'COMPILE ↑W ↑R)
(GO A))
(T (AND (SETQ X (GETL CH '(*EXPR *FEXPR *LEXPR)))
(NOT (EQ FL (CDR (ASSQ (CAR X) DECTB))))
(WRNTYP CH))
(PUTPROP CH T (CAAR (ASSOCR FL DECTB)))
(COUTPUT FORM))))
(T (SETQ LAP-INSIGNIF NIL) (COUTPUT FORM)))
(AND RECOMPL (GO A)))
((COND ((AND (EQ (CAR FORM) 'ARRAY) (SETQ X (CADR FORM)))
(MEMQ (SETQ FL (CADDR FORM)) '(T NIL FIXNUM FLONUM OBARRAY)))
((AND (EQ (CAR FORM) '*ARRAY)
(P1EQQTE (CADR FORM))
(SETQ X (CADADR FORM))
(COND ((MEMQ (SETQ FL (CADDR FORM)) '(T NIL)))
((P1EQQTE FL)
(MEMQ (SETQ FL (CADR FL))
'(T NIL FIXNUM FLONUM OBARRAY READTABLE)))))))
(AND (NOT (MEMQ FL '(FIXNUM FLONUM))) (SETQ FL 'NOTYPE))
(SETQ CH X)
(DO ((L (CDDDR FORM) (CDR L)) (Z) (T1))
((NULL L) (SETQ X (LIST (CONS X (NREVERSE Z)))))
(COND ((OR (FIXP (SETQ T1 (CAR L)))
(AND (P1EQQTE T1) (FIXP (SETQ T1 (CADR T1)))))
#(PUSH T1 Z))
(T (SETQ X (LIST X (LENGTH (CDDDR FORM)))) (RETURN NIL))))
(COND ((GET CH '*ARRAY)
(PUTPROP CH NIL '*ARRAY) ;TO PREVENT SPURIOUS RE-DECLARED MSGS
((LAMBDA (T1) (AND (COND (T1 (PUTPROP CH NIL 'NUMFUN)
(COND ((CADR T1) (NOT (EQ (CADR T1) FL)))
((NOT (EQ FL 'NOTYPE)))))
((NOT (EQ FL 'NOTYPE))))
(PUTPROP CH '(NIL NIL) 'NUMFUN)))
(GET CH 'NUMFUN))))
(AR*1 (CONS FL X))
(AND (MEMQ CH FFVL) (GO F))
(SETQ LAP-INSIGNIF NIL)
(COUTPUT FORM))
((EQ (CAR FORM) 'DECLARE)
(SETQ X INFILE)
(AND (NULL (ERRSET (MAPC 'EVAL (CDR FORM)) LISPERRP))
DATAERRP ;UNLESS DECLARATIONS LOSE, DO THEM
(GO C)) ;AND GO TO NEXT EXPRESSION IN FILE
(COND ((NOT (EQ INFILE X))
(EOFFN INFILE 'COEFN)
(MAPC '(LAMBDA (F) (OR (EQ F TYI) (EOFFN F 'COEFN))) INSTACK)))
(GO A))
((AND NIOP/| (EQ (CAR FORM) 'INCLUDE))
(AND (NULL (ERRSET (SETQ FL (EVAL FORM)))) DATAERRP (GO C))
(COND (TTYNOTES
((LAMBDA (↑R ↑W)
(CMSGINDENT 1)
(PRINC '|;INCLUDING FILE |)
(PRINC (NAMESTRING (TRUENAME FL))))
NIL NIL)))
(EOFFN FL 'COEFN)
(GO A))
((EQ (CAR FORM) 'CGOL) (CGOL))
((AND (EQ (CAR FORM) 'LAP)
(CDR FORM)
(ATOM (CADR FORM))
(CDDR FORM)
(ATOM (CADDR FORM)))
(SETQ UNDFUNS (DELQ (CADR FORM) UNDFUNS))
(SETQ FL (CDR (ASSQ (CADDR FORM) '((SUBR . *EXPR) (FSUBR . *FEXPR) (LSUBR . *LEXPR)))))
(COND ((SETQ X (GETL (CADR FORM) '(*EXPR *FEXPR *LEXPR)))
(AND (NOT (EQ (CAR X) FL)) (WRNTYP (CADR FORM))))
(FL (PUTPROP (CADR FORM) FL T)))
(COND ((AND RECOMPL (NOT (MEMQ (CADR FORM) RECOMPL)))
(ZAP2NIL FORM NIL))
(FASLPUSH (FASLIFY (NREVERSE (PROG2 NIL LAPLL (SETQ LAPLL NIL))) 'LIST)
(FASLIFY FORM 'LAP)) ;HACK THE LAP CODE
(T (ZAP2NIL FORM T)
(AND TTYNOTES ((LAMBDA (↑R ↑W)
(PRINT (CADR FORM))
(PRINC '|LAP CODE ZAPPED |))
NIL NIL))))
(SETQ LAP-INSIGNIF NIL))
((AND FORM (ATOM (CAR FORM)) (SETQ FL (GET (CAR FORM) 'MACRO)))
(SETQ IRASLOSS DECTB)
(COND ((OR (NULL (ERRSET (SETQ IRASLOSS (FUNCALL FL FORM)) LISPERRP))
(EQ IRASLOSS DECTB))
(AND DATAERRP (GO C)))
(IRASLOSS (SETQ FORM IRASLOSS) (GO B)))) ;APPLY MACRO PROPERTY AND TRY AGAIN
((AND (EQ (CAR FORM) 'PROGN) ;(PROGN 'COMPILE . . .)
(NOT (ATOM (CADR FORM)))
(EQ (CAADR FORM) 'QUOTE)
(EQ (CADADR FORM) 'COMPILE))
(SETQ PRATTSTACK (CDDR FORM))
(GO A))
((NOT RECOMPL) (SETQ LAP-INSIGNIF NIL) (COUTPUT FORM)))
(AND (NOT FASLPUSH) (COUTPUT GOFOO))
(GO A)
C ((LAMBDA (↑Q ↑R ↑W OUTFILES READ TERPRI)
(COND ((OR NIOP/| (EQ MESSIOC CLPROGN)) (SETQ ↑R T ↑W T))
((APPLY 'IOC MESSIOC)))
(SETQ ↑W (NOT DATAERRP))
(PRINC '|/
(COMMENT **** |)
(PRIN1 FORM)
(PRINC '|)/
;LISP ERROR IN FORM DURING DECLARATION OR MACRO EXPANSION. /
;PLEASE CORRECT, AND TYPE $P TO CONTINUE |)
(BREAK DATA DATAERRP))
NIL NIL NIL CMSGFILES NIL T)
(GO A)
GH (DBARF FORM |ILGL DEFUN FORMAT| 4 4)
F (DBARF (ASSQ CH FFVL) |FIRST FUNCTION OF LIST USED AS FUNCTIONAL VARIALBLE /
IN THE OTHER FUNCTIONS. - YOU WILL LOSE|)))
SYMBOLS CREADTABLE COBARRAY))
(DEFUN COEFN (FIL EOFVAL) ;STANDARD EOFFN FOR NEWIO
(DECLARE (SPECIAL INFILE INSTACK))
(AND (EQ FIL INFILE) (INPUSH -1)) ;POP FILE OFF STACK
(COND (TTYNOTES
((LAMBDA (↑R ↑W)
(CMSGINDENT 0)
(PRINC '|;END OF FILE |)
(PRINC (NAMESTRING (TRUENAME FIL))))
NIL NIL)))
(CLOSE FIL) ;CLOSE FILE
(COND (INSTACK T) ;IF MORE IS ON STACK, KEEP READING;
(T EOFVAL))) ; OTHERWISE WE HAVE A REAL EOF
(DEFUN CMSGINDENT (J) ;TERPRI AND INDENT PROPORTIONAL TO LENGTH OF INSTACK
(DECLARE (FIXNUM J))
(TERPRI)
(DO ((I J (+ I 1))
(N (- (LENGTH INSTACK) 2)))
((> I N))
(DECLARE (FIXNUM I N))
(PRINC '| |)))
(DEFUN CL FEXPR (L)
; COMPILE A LIST OF FUNCTION S GIVEN BY ATOM NAME
((LAMBDA (LAPLL DATA SYMBOLS READTABLE TOPFN FFVL BARFP COMPILER-STATE)
(CONS 'COMMENT
(MAPCAR '(LAMBDA (J) (AND (SETQ DATA (GETL J '(EXPR FEXPR)))
(PROG2 (SETQ CFVFL NIL)
(COMPILE J (CAR DATA) (CADR DATA) NIL NIL))))
(SETQ CL (OR L CL)))))
NIL NIL SYMBOLS CREADTABLE NIL NIL T 'COMPILE))
(DEFUN LAP-FILE-MSG (REALI L)
(DECLARE (SPECIAL UNFASLCRFL))
((LAMBDA (TEM TERPRI OUTFILES)
(SETQ TEM (STATUS DATE))
(SETQ ↑W (SETQ ↑R T) LINE NIL)
(COND (FASLPUSH (UNFASL-MSG REALI))
(T (PRINC '|/
'(THIS IS THE LAP FOR |)
(PRIN1 REALI)
(PRINC '|)|)))
(PRINC ##(LIST 'QUOTE
(MAKNAM (NCONC (EXPLODEN '|/
'(COMPILED BY LISP COMPILER //|)
(EXPLODEN (STARTER))))))
(AND NIOP/| (PRINC '| IN NEWIO|))
(PRINC '|)/
|)
(COND (TEM
((LAMBDA (BASE *NOPOINT APM II)
(PRINC '|;COMPILED ON |)
(COND ((AND (NOT TOPS10P) (SETQ APM (STATUS DOW)))
(PRINC APM)
(SETQ APM 'AM)
(PRINC '|, |)))
(PRINC (CAR (NCDR '(JANUARY FEBRUARY MARCH APRIL MAY JUNE
JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER)
(1- (CADR TEM)))))
(PRINC '| |)
(PRINC (CADDR TEM))
(PRINC '|, |)
(PRINC (+ 1900. (CAR TEM)))
(COND ((SETQ TEM (STATUS DAYTIME))
(PRINC '|, AT |)
(SETQ II (CAR TEM))
(COND ((ZEROP II)
(AND (= (CADR TEM) 0) (SETQ APM 'MIDNITE))
(PRINC '/12))
((= II 12.)
(SETQ APM (COND ((= (CADR TEM) 0) 'NOON)
('PM)))
(PRINC '/12))
(T (AND (> II 12.) (SETQ APM 'PM II (- II 12.)))
(PRINC II)))
(COND ((< (CADR TEM) 10.) (PRINC '/:/0))
(T (PRINC '/:)))
(PRINC (CADR TEM))
(PRINC '/ )
(PRINC APM)))
(TERPRI))
10. T 'AM 0)))
(AND FASLPUSH (SETQ UNFASLCRFL NIL))
(SETQ LAP-INSIGNIF T))
NIL T L))
;;; FROM HERE TO ZAP2NIL CAN BE USED AS FASLAP DRIVER FOR STAND-ALONE
;;; FASLAP. ONLY BE SURE TO CUT OUT THE PORTION THAT CAUSES
;;; COMPILATION, NAMELY BETWEEN THE TAGS CHOMP1 AND CHOMP2
;;; AND TO CAUSE THE DEFAULT OF THE SWITCH "ASSEMBLE" TO BE T
(DEFUN MAKLAP FEXPR (L)
(DECLARE ;VARIABLES BOUND ONLY FOR THE BENEFIT OF FASLAP
(SPECIAL CURRENTFNSYMS LOC FILOC CURRENTFN IMOSAR MAINSYMPDL FBARP
UNFASLCRFL UNFASLSIGNIF ENTRYNAMES SYMPDL LITLOC BINWORDS
ALLATOMS NUMBERTABLE ATOMINDEX DDTSYMP SYMBOLSP LITERALS
UFFIL))
((LAMBDA (EOC-EVAL RECOMPL LINEL READ OCMSGFILES INFILE)
(PROG (CH LINE INMLS ONMLS DEV USR TEM JCLP REALI II FSLNL
TOPFN SWITCHLIST OPNDP FASLERR COMPILER-STATE LAP-INSIGNIF
↑W ↑Q ↑R CURRENTFNSYMS LOC FILOC CURRENTFN MAINSYMPDL
UNFASLCRFL UNFASLSIGNIF ENTRYNAMES ALLATOMS LITLOC FBARP
SYMPDL NUMBERTABLE ATOMINDEX DDTSYMP SYMBOLSP LITERALS
OUTFILES INSTACK UFFIL CMSGFILES)
;JCLP, REALI, AND TEM ARE UNSPECIAL
;FROM FASL TO SPECIAL ARE THE DOZEN COMPLR SWITCHES
B0 (SETQ UNDFUNS NIL COMPILER-STATE 'MAKLAP FSLNL NIL
REALI NIL FASLPUSH NIL LAP-INSIGNIF T FASLERR NIL
CMSGFILES OCMSGFILES)
(AND (NULL L)
(SETQ FASL NIL NOLAP NIL ASSEMBLE NIL TTYNOTES NIL
DISOWNED NIL UNFASLCOMMENTS NIL INITIALIZE NIL))
B (SETQ ↑W (SETQ ↑R (SETQ ↑Q NIL)))
(SETQ LINE (LIST 105105) SWITCHLIST NIL INMLS NIL)
(COND (L (COND ((AND (CAR L) (ATOM (CAR L)))
(SETQ JCLP T LINE L L NIL)
(GO A1))) ;COMPILATION BEGUN FROM JCL
(AND (NOT DISOWNED) (TERPRI))
(MAKJPG (CAR L))
(COND ((CDR L)
(SETQ ONMLS (RDSYL))
(SETQ INMLS (MAPCAN '(LAMBDA (L) (MAKJPG L) (RDSYL))
(CDR L)))
(SETQ TEM (FASL-LAP-P)))
(T (SETQ INMLS (RDSYL))
(SETQ TEM (FASL-LAP-P))
(SETQ ONMLS (LIST (CONS (CAAR INMLS)
(CONS TEM
(CDDAR INMLS)))))))
(AND (OR (MEMQ NIL INMLS) (MEMQ NIL ONMLS))
(GO IIS))
(GO D1)))
(TERPRI)
(PRINC '/←)
(COND (NIOP/|
(AND (NUMBERP (SETQ TEM (READLINE T 0))) (GO B))
(MAP '(LAMBDA (X) (AND (< 140 (CAR X))
(< (CAR X) 173)
(RPLACA X (- (CAR X) 40))))
(SETQ LINE (NRECONC (EXPLODEN TEM) LINE)))
(GO A1)))
OLDIOREADLINE1
(SSTATUS TTY 232020202022 232020220233)
A (AND (LESSP 140 (SETQ II (TYI)) 173) (SETQ II (- II 40)))
(COND ((= II 177) ;THE UBIQUITOUS RUBOUT
(COND ((= (CAR LINE) 105105) (GO B))
((OR (LESSP 0 TTY 4) (= TTY 5) (= TTY 7))
(CURSORPOS 'B) (CURSORPOS 'L))
(T (TYO (CAR LINE))))
#(POP LINE)
(GO A))
((COND ((= II 14) (CURSORPOS 'C) T)
((= II 13))) ;↑L AND ↑K REPRINT LINE BUFFER
(PRINC '/
/←)
(MAPC 'TYO (CDR (REVERSE LINE)))
(GO A))
((= II 57) ;SLASH WORKS AS ESCAPE
(SETQ LINE (CONS (TYI) (CONS 57 LINE)))
(GO A))
((NOT (= II 15)) #(PUSH II LINE) (GO A))
((AND (NOT (ZEROP (LISTEN))) (= (TYIPEEK) 12) (TYI)))
((AND TOPS10P (= (LENGTH LINE) 1)) (GO A)))
OLDIOREADLINE2
A1 (SETQ TEM (RDSYL))
(COND ((NOT (LESSP 2 (SETQ II (LENGTH (CAR TEM))) 5)) ;TEM=(NIL) ON DETECTED ERRORS
(GO IIS))
((= II 3)
(RPLACA TEM (CONS (CAAR TEM) (CONS (COND (TOPS10P '/ )(T '>)) (CDAR TEM))))))
(SETQ INMLS (NCONC TEM INMLS))
(AND (= CH 54) (GO A1)) ;COMMA SEPARATES MULTIPLE SOURCES
(COND ((= (CAR LINE) 105105)
(SETQ ONMLS (LIST (CDDAR INMLS)) II 2)) ;IF NO SINK, DEFAULT DEV,USR TO FIRST SOURCE
((NOT (LESSP 1 (SETQ II (LENGTH (CAR (SETQ ONMLS (RDSYL))))) 5))
(GO IIS)))
(SETQ TEM (FASL-LAP-P))
(AND (NOT (= II 4))
(SETQ ONMLS (LIST (CONS (CAAR (COND ((= II 3) ONMLS) (INMLS)))
(CONS TEM (COND ((= II 3) (CDAR ONMLS)) ((CAR ONMLS))))))))
D1 (SETQ FASLPUSH (AND (NOT ASSEMBLE) NOLAP))
(SETQ DEV NIL USR NIL) ;DO DEVICE AND USR DEFAULTING
(MAPC '(LAMBDA (X) (COND ((NULL (CADDR X))
(RPLACA (CDDR X) (COND (DEV) ((SETQ DEV 'DSK)))))
((NOT TOPS10P)(SETQ DEV (CADDR X))))
(COND ((NULL (CADDDR X))
(RPLACA (CDDDR X) (COND (USR) ((SETQ USR (STATUS UDIR))))))
((NOT TOPS10P)(SETQ USR (CADDDR X))))
NIL)
(APPEND ONMLS INMLS))
(COND ((APPLY 'UPROBE (CAR INMLS))
(COND (NIOP/|
(SETQ REALI (TRUENAME (INPUSH (OPEN (DEFAULTF (CAR INMLS)) 'IN))))
(SETQ REALI (APPEND (CDR REALI) (CAR REALI))))
(T (APPLY 'EREAD (CAR INMLS)) (SETQ REALI (STATUS UREAD))))
((LAMBDA (BASE *NOPOINT)
(SETQ GENPREFIX
(NCONC (COND (TOPS10P
(NCONC (LIST '/[)
(EXPLODEC (CAR (CADDDR REALI)))
(LIST '/,)
(EXPLODEC (CADR (CADDDR REALI)))
(LIST '/])))
(T (NCONC (EXPLODEC (CADDDR REALI)) (LIST '/;))))
(EXPLODEC (CAR REALI))
'(/-))))
10. T))
((AND L (NOT JCLP)) (RETURN NIL))
(T (PRIN1 (CAR INMLS))
(PRINC '| FILE NOT FOUND - MAKLAP|)
(GO B0)))
(AND JCLP TTYNOTES (SETQ JCLP NIL))
(AND (OR DISOWNED JCLP) (GIVUPTTY))
(COND (ASSEMBLE (FASL-A-FILE (CAR ONMLS) INMLS)
(AND NOLAP
(NOT (MEMBER (CAR ONMLS) INMLS))
(MAPC 'UKILL INMLS))
(GO E2)))
CHOMP1
(COND (FASLPUSH (FASL-START (SETQ FSLNL (CAR ONMLS)) NIL))
(T (AND FASL
(SETQ ONMLS (LIST (CONS (CAR (SETQ FSLNL (CAR ONMLS)))
(CONS 'LAP
(CONS 'DSK (CDDDAR ONMLS)))))))
(APPLY 'UWRITE (CDDAR ONMLS)) ;OPENS THE LAP OUTPUT FILE
(AND NIOP/| #(PUSH UWRITE CMSGFILES) (LINEL UWRITE 80.))))
(AND TTYNOTES (NOT (MEMQ T CMSGFILES)) #(PUSH T CMSGFILES))
(SETQ OPNDP T)
D2 (COND ((NULL (CAR INMLS)) (WARN NIL |PHOOEY ON JPG|) (GO E2)))
(COND (OPNDP (SETQ OPNDP NIL REALI (LIST REALI)))
(T (APPLY 'EREAD (CAR INMLS))
#(PUSH (STATUS UREAD) REALI)))
(COND (TTYNOTES
((LAMBDA (↑Q ↑R ↑W) ;IN NIOP/|, CAN USE (PRIN1 FOO T)
(PRINC '|/
COMPILATION BEGUN ON |)
(PRIN1 (CAR REALI))
(PRINC '| |))
NIL NIL NIL)))
(LAP-FILE-MSG (CAR REALI) (COND ((NOT NIOP/|) NIL) ;SETS LAP-INSIGNIF TO T
(FASLPUSH UFFIL) ;AS WELL AS ↑R ↑W
(T (CONS UWRITE UFFIL))))
C (SETQ ↑Q T TOPFN NIL
TEM (COND ((NULL ↑Q) CLPROGN)
((ERRSET (CMP1) LISPERRP))))
(SETQ TOPFN NIL)
(COND ((ATOM TEM)
(COND (FASLPUSH (SETQ FASLERR T))
(T (SETQ ↑W T ↑R T) (PRINC '| NIL |) (TYO 14)))
(SETQ LINE (CONS CH LINE)) ;LINE ACCUMULATES FUNCTION NAMES THAT COP OUT
(AND (NULL TEM) LISPERRP ((LAMBDA (↑R READ) (BREAK LISPERRP T)) NIL NIL))
(GO C))
(LINE #(WARN (SETQ LINE (NREVERSE LINE)) |- FAILED TO COMPILE|)))
(COND ((SETQ INMLS (CDR INMLS)) (GO D2)))
(COND (UNDFUNS #(WARN UNDFUNS |HAVE BEEN USED BUT REMAIN UNDEFINED IN THIS FILE|)))
(SETQ REALI (NREVERSE REALI))
(AND TTYNOTES
((LAMBDA (↑Q ↑R ↑W)
(TERPRI)
(PRINT (COND ((CDR REALI) REALI) ((CAR REALI)))) ;IN NIOP/|, CAN USE (PRINT FOO T)
(PRINC '| FINISHED COMPILATION |))
NIL NIL NIL))
(COND (FASLERR
(AND FASLPUSH (FASL-CLOSEOUT NIL NIL FSLNL))
#(WARN NIL |
*** FASLIZATION ABORTED DUE TO ERRORS ***|))
(FASLPUSH
(FASL-CLOSEOUT (CAR ONMLS)
(AND (NOT FASLERR) (NOT LAP-INSIGNIF) REALI)
FSLNL))
(T
(APPLY 'UFILE (CAR ONMLS)) ;CLOSES LAP FILE
(SETQ ONMLS (NREVERSE ONMLS))
(AND FSLNL (FASL-A-FILE FSLNL ONMLS))))
CHOMP2
E2 (MAPC 'EVAL EOC-EVAL)
E2+1 (COND (L (RETURN NIL))
(T (AND (OR JCLP DISOWNED) (VALRET '|}_.|))
(GO B0)))
IIS (PRINC '|INCORRECT COMMAND SYNTAX - MAKLAP|)
(COND (L (RETURN NIL))
(JCLP (GO B0))
(T (GO E2+1)))))
EOC-EVAL
RECOMPL
120. ;LINEL
READ
CMSGFILES
T)) ;INFILE
(DEFUN FASL-LAP-P NIL
(AND INITIALIZE (INITIALIZE))
(MAPC 'SETQ SWITCHLIST)
(COND ((OR ASSEMBLE NOLAP FASL) 'FASL) ('LAP)))
;RETURNS "LAP" IFF THIS RUN IS COMPILE ONLY
(DEFUN TTYNOTES (X)
(SETQ TTYNOTES X)
(AND NIOP/| (MEMQ T CMSGFILES) (SETQ CMSGFILES (DELQ T (APPEND CMSGFILES NIL))))
TTYNOTES)
(DEFUN GIVUPTTY NIL
(SETQ LISPERRP NIL DATAERRP NIL BARFP NIL MESSIOC CLPROGN ↑W T)
(TTYNOTES NIL)
(AND (STATUS TTY)
(STATUS HACTRN)
(VALRET (COND (DISOWNED '|:PROCED :DISOWN |) ('|:PROCED |)))))
(DEFUN SPLITFILE FEXPR (L)
(COND ((OR ASSEMBLE (NULL L) (CDR L))
(SETQ L (CONS 'SPLITFILE L))
(COND (ASSEMBLE (PDERR L |SPLITFILE NOT YET IMPLEMENTED FOR "A" SWITCH|))
((PDERR L |LOSE LOSE - SPLITFILE|))))
((PROG2 (SETQ L (CONS (CAR L) (CDAR ONMLS))) FASLPUSH)
(FASL-CLOSEOUT (CAR ONMLS)
(COND (LAP-INSIGNIF #(POP ONMLS) NIL) ;NIL FLUSHES NULL FASL FILE
(T (FASLIFY (NREVERSE (PROG2 NIL LAPLL (SETQ LAPLL NIL)))
'LIST)
(CAR ONMLS)))
NIL) ;DONT CLOSE UNFASL FILE
(FASL-START L T) ;BUT DO CONTINUE IT
(UNFASL-MSG L)
#(PUSH L ONMLS))
(T (APPLY 'UFILE (CAR ONMLS))
(COND (LAP-INSIGNIF (APPLY 'UKILL (CAR ONMLS)) #(POP ONMLS)))
(APPLY 'UWRITE (CDDR L))
(LAP-FILE-MSG L (AND NIOP/|(LIST UWRITE))) ;SETS LAP-INSIGNIF TO T
#(PUSH L ONMLS)))) ;AS WELL AS ↑R ↑W
(DEFUN MAKJPG (L)
((LAMBDA (LL)
(SETQ LINE
(NREVERSE
(NCONC LINE
(EXPLODEN (CAR L))
(LIST 40)
(EXPLODEN (CADR L))
(LIST 40)
(COND (LL (NCONC (EXPLODEN (CAR LL)) (LIST 72 40))))
(COND ((AND LL (CDR LL))
(NCONC (EXPLODEN (CADR LL))
(LIST 73 40))))))))
(CDDR L)))
(DEFUN RDSYL NIL
(PROG (L TEM)
(SETQ DEV (AND TOPS10P 'DSK) USR NIL)
A (SETQ CH (CAR LINE))
(COND ((= CH 105105) (GO RET))
((AND TOPS10P (= CH 135))
(SETQ LINE (CDR LINE) USR (RDSYL2 T))
(COND ((NULL USR)
(PRINC '/
/")
(PRINC (MAKNAM (CDR (REVERSE LINE))))
(PRINC '|"HAS ILGL PPN SPEC/
|)
(RETURN NIL))))
((OR (FNCP CH) (= (CADR LINE) 57))
(SETQ L (CONS (RDSYL2 NIL) L)))
((= CH 72)
(SETQ LINE (CDR LINE) DEV (RDSYL2 NIL))) ;COLON TRIGGERS DEV NAME
((= CH 73)
(SETQ LINE (CDR LINE) USR (RDSYL2 NIL))) ;SEMI-COLON TRIGGERS DIR NAME
((= CH 51) ;RPAREN TRIGGERS SWITCHES
(COND ((NULL (SETQ TEM (RDSYL3 (CDR LINE))))
(PRINC '/
/")
(PRINC (MAKNAM (CDR (REVERSE LINE))))
(PRINC '/"/ HAS/ ILGL/ SWITCH/ REQUEST/
)
(RETURN NIL)))
(SETQ LINE (CDR TEM)) ;STRIP OFF "("
(GO A)) ;FOO ")"
((OR (= CH 137) (= CH 54)) ;LEFT-ARROW OR COMMA
#(POP LINE)
(GO RET))
((COND ((= CH 40)) ;SPACE IS FILE-NAME SEPARATOR
(TOPS10P (= CH 56))) ;AND ON DEC10, SO IS .
(SETQ LINE (CDR LINE)))
((< CH 40) #(POP LINE) (GO A))
(T (PRINC '/
/")
(TYO CH)
(PRINC '/"?/ ILGL/ CHAR/
)
(RETURN NIL)))
(GO A)
RET (RETURN (LIST (NCONC L (LIST DEV USR))))))
(DEFUN RDSYL2 (PPNP)
(PROG (Y Z PRJ)
A (SETQ Y (CAR LINE))
(COND ((= Y 105105) (GO X))
((OR (= (CADR LINE) 57) (= (CADR LINE) 21)) #(POP LINE)) ;SLASH IS ESCAPE
((= Y 56) (AND TOPS10P (GO X))) ;. IS BREAK ON DEC10
((< Y 40) (GO B))
((AND TOPS10P
PPNP
(COND ((= Y 54) (SETQ PRJ (RDSYLPPN Z) Z NIL) (GO B) T)
((= Y 133)
#(POP LINE)
(SETQ Z (RDSYLPPN Z))
(AND (OR (NULL Z) (NULL PRJ)) (RETURN NIL))
(RETURN (LIST Z PRJ))
T))))
((NOT (FNCP Y)) (GO X)))
#(PUSH Y Z)
B #(POP LINE)
(GO A)
X (AND PPNP (RETURN NIL))
(RETURN (IMPLODE Z))))
(DEFUN RDSYLPPN (Z)
(COND ((STATUS FEATURE SAIL) (IMPLODE Z))
((DO ((N 0)) ((NULL Z) N)
(AND (OR (< (CAR Z) 60) (> (CAR Z) 71)) (RETURN NIL))
(SETQ N (+ (* N 10.) (- (CAR Z) 60))
Z (CDR Z))))))
(DEFUN RDSYL3 (L) ;MAKLAP COMMAND LINE SWITCH PARSER
(DO ((L L (CDR L)) (OBARRAY SOBARRAY) (T2))
((COND ((= (CAR L) 50)) ;LPARENS
((OR (= (CAR L) 137) (= (CAR L) 105105)) ;LARRROW OR END-OF-LINE
(SETQ L NIL)
T))
L)
(COND ((NOT (> (CAR L) 40))) ;IGNORE SPACE AND TAB
((> (CAR L) 177) (SETQ L '(137 137)))
((EQ (SETQ T2 (ASCII (CAR L))) 'I) (SETQ INITIALIZE T))
((SETQ T2 (ASSQ T2
'((F . FASL) (K . NOLAP) (A . ASSEMBLE) (V . NFUNVARS)
(E . EXPR-HASH) (X . MAPEX) (T . TTYNOTES) (D . DISOWNED)
(Z . SYMBOLS) (M . MACROS) (N . NOARGS)
(S . SPECIAL) (U . UNFASLCOMMENTS) (W . MUZZLED))))
#(PUSH (LIST (CDR T2) (SETQ T2 (NOT (= (CADR L) 55)))) ;- MEANS SET SWITCH TO NIL
SWITCHLIST) ;ELSE SET TO T
(COND ((NOT T2) (SETQ L (CDR L)))))
(T (SETQ L '(137 137)))))) ;BOMB OUT IF NOT RECOGNIZE
(DEFUN FNCP (II) ;FILE-NAME-CHARACTER-PREDICATE
(OR (LESSP 73 II 137) ;GETS <, ?, @, A-Z, [, \, ], ↑
(LESSP 57 II 72) ;GETS 0 - 9
(LESSP 40 II 50) ;GETS ! TO ' (TOPS OF 1 TO 4)
(= II 53) (= II 55) ;GETS + AND -
(COND (TOPS10P NIL)
((OR (= II 52) ;GETS *
(= II 56)))))) ;GETS .
(DEFUN REMPROPL (FL LL) (MAPC '(LAMBDA (X) (REMPROP X FL)) LL))
(DEFUN LREMPROP (NAME L)
(PROG (V FL)
A (SETQ V (GETL NAME L))
(AND (NULL V) (RETURN FL))
(COND ((REMPROP NAME (CAR V)) (SETQ FL T)))
(GO A)))
(DEFUN MSOUT (W FUN FLAG L1 L2)
(DECLARE (SPECIAL UNFASLSIGNIF))
((LAMBDA (OUTFILES TERPRI PRINLEVEL PRINLENGTH)
(PROG (↑R ↑W)
(COND (NIOP/|
(SETQ ↑R T ↑W T)
(AND (COND ((EQ FLAG 'BARF) BARFP)
((MEMQ FLAG '(ERRFL DATA)) DATAERRP))
(NOT (MEMQ T OUTFILES))
(NOT (MEMQ TYO OUTFILES))
(SETQ ↑W NIL)))
((EQ MESSIOC CLPROGN) (SETQ ↑R T ↑W T))
((NULL MESSIOC))
(T (APPLY 'IOC MESSIOC)
(AND ↑W (NOT (EQ FLAG 'WARN)) ;OVERRIDE TTY SWITCH IF THIS
(NOT (EQ MESSIOC CLPROGN)) ;IS NOT MERELY A WARNING
(SETQ ↑W NIL))))
(AND ↑R (SETQ UNFASLSIGNIF ↑R))
(PRINC '|/
/(COMMENT **** |)
(COND (W (PRIN1 W) (PRINC '| |)))
##(COND ((NOT (MEMQ COMPILER-STATE '(NIL TOPLEVEL)))
'(SUBRCALL T (GET FUN 'SUBR)))
('(FUNCALL FUN)))
(COND (TOPFN (PRINC '| IN FUNCTION |) (PRIN1 TOPFN)))
(PRINC '/))
(COND ((MEMQ FLAG '(ERRFL DATA))
(COND (DATAERRP
((LAMBDA (↑W ↑R ARGS READ)
(PRINC '|/
; DATA ERROR - TO PROCEED TYPE $P |)
(BREAK DATA))
NIL NIL W NIL)
(TERPRI)))
(COND ((EQ FLAG 'ERRFL) (SETQ ERRFL T))
(T (ERR 'DATA))))
((EQ FLAG 'BARF)
(PRINC '|/
;%%%%%%%% COMPILER ERROR - CALL JONL %%%%%%%%|)
((LAMBDA (OBARRAY READTABLE ARGS READ) (BREAK BARF BARFP))
OBARRAY READTABLE W NIL)
(TERPRI)
(ERR 'BARF)))))
CMSGFILES T L1 L2))
(DEFUN ZAP2NIL (FORM FL)
(DECLARE (SPECIAL LINEL UWRITE) (FIXNUM LINEL CHAR))
((LAMBDA (N LINEL ↑R ↑W)
(COND (FL (TERPRI)
(AND NIOP/| (LINEL UWRITE 0.))
(PRINT FORM)))
(PROG (CHAR FLAG)
A (SETQ CHAR (ZTYI))
(COND ((= CHAR 15) ;<CARRIAGE-RETURN>
(AND (= 12 (TYIPEEK)) (TYI)) ;FLUSH ANY FOLLOWING LINE-FEED
(SETQ FLAG NIL))
(FLAG)
((= CHAR 57) (AND FL (TYO CHAR)) (SETQ CHAR (ZTYI))) ; |/|
((= CHAR 73) (SETQ FLAG T)) ; |;|
((= CHAR 50) ; |(|
(AND (ZEROP N)
(= (TYIPEEK) 51) ; |)|
(PROG2 (AND FL (PRINC '|()/
|) (TYO 14))
(RETURN NIL)))
(SETQ N (1+ N)))
((= CHAR 51) (SETQ N (1- N))) ; |)|
((AND (OR (= CHAR 116) (= CHAR 156)) (ZEROP N)) ; |N|, |n|
(AND FL (TYO CHAR))
(COND ((OR (= (SETQ CHAR (ZTYI)) 111) (= CHAR 151)) ; |I|, |i|
(AND FL (TYO CHAR))
(COND ((OR (= (SETQ CHAR (ZTYI)) 114) ; |L|, |l|
(= CHAR 154))
(AND FL (TYO CHAR))
(COND ((= (SETQ CHAR (ZTYI)) 40)
(AND FL (PRINC '| /
|) (TYO 14))
(RETURN NIL)))))))))
(AND FL (TYO CHAR))
(GO A))
(AND NIOP/| (LINEL UWRITE 120.)))
0 500. T T))
(DEFUN ZTYI NIL
((LAMBDA (CHAR)
(AND (= CHAR 3)
(SETQ TOPFN (CADR DATA)) ;SET UP NAME OF LOSING LAP FUNCTION
(DBARF NIL |EOF IN MIDDLE OF LAP CODE - /
CHECK FOR MISBALANCED PARENS|))
CHAR)
(TYI 3)))
(COMMENT PROPERTIES OF VARIOUS SYMBOLS)
(PROGN (DEFPROP RPLACD (HRRM . HRRM) INST)
(DEFPROP RPLACA (HRLM . HRLM) INST)
(DEFPROP RPLACD (HLLZS . HLLZS) INSTN)
(DEFPROP RPLACA (HRRZS . HRRZS) INSTN)
(DEFPROP SETPLIST (HRRM . HRRM) INST)
(DEFPROP SETPLIST (HLLZS . HLLZS) INSTN)
(DEFPROP A (HLRZ . HLRZ) INST)
(DEFPROP D (HRRZ . HRRZ) INST)
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'IMMED))
'(MOVE CAMN CAME
ADD SUB IMUL IDIV CAMLE CAMG CAML CAMGE MOVN
AND ORCB SETCM XOR EQV IOR ANDCB ANDCA ANDCM ORCM ORCA)
'(MOVEI CAIN CAIE
ADDI SUBI IMULI IDIVI CAILE CAIG CAIL CAIGE MOVNI
ANDI ORCBI SETCMI XORI EQVI IORI ANDCBI ANDCAI ANDCMI ORCMI ORCAI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'COMMU) (PUTPROP INSTN INST 'COMMU))
'(CONS *GREAT *PLUS *TIMES EQUAL CAMG CAMGE JUMPGE JUMPL)
'(XCONS *LESS *PLUS *TIMES EQUAL CAML CAMLE JUMPLE JUMPG))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'CONV) (PUTPROP INSTN INST 'CONV))
'(JUMP JUMPL JUMPE JUMPLE TRNN TLNN SOJE CAMG CAML
CAMN CAIG CAIL CAIE SKIPE SKIPG SKIPL)
'(JUMPA JUMPGE JUMPN JUMPG TRNE TLNE SOJN CAMLE CAMGE
CAME CAILE CAIGE CAIN SKIPN SKIPLE SKIPGE))
(DO ((Z '((A . A) (NIL . A) (A . NIL) (B . B) (NIL . B)))
(Y '((TTY TTYRE TTYTY TTYCO TTYSC TTYIN LINMO TERPR PDLMA INTER)
(DIVOV FTVSI + TOPLE UUOLI ABBRE GCMIN GCTIM
PAGEP BREAK EVALH MAR WHO1 WHO2 WHO3 /← LOSEF)
(SYSTE SPCSI PURSI PDLSI PDLRO FILEM TTYSI)
(MACRO SYNTA CHTRA)
(FREE))
(CDR Y)))
((NULL Y))
(MAPC '(LAMBDA (X) (PUTPROP X (CAR Z) 'STATUS)) (CAR Y)))
((LAMBDA (GL)
(DEFUN GENCR (CARCDR LDLST)
((LAMBDA (EXIT EXITN)
(PUTPROP EXIT (CONS 'A (CONS CARCDR (CAR GL))) 'CARCDR)
(PUTPROP EXITN (CONS 'D (CONS CARCDR (CADR GL))) 'CARCDR)
(SETQ GL (CDDR GL))
(COND ((< (LENGTH LDLST) 3)
(GENCR EXIT (CONS 'A LDLST))
(GENCR EXITN (CONS 'D LDLST)))))
(IMPLODE (APPEND '(C A) LDLST '(R)))
(IMPLODE (APPEND '(C D) LDLST '(R)))))
(GENCR NIL NIL))
'(6. 14. 5. 13. 19. 24. 27. 33. 36. 30. 3. 11. 17. 22. 1. 9.
4. 12. 18. 23. 26. 32. 35. 29. 2. 10. 16. 21. 0. 8.)) ;BOY! ARE THESE NUMBERS RANDOM!
(REMPROP 'GENCR 'EXPR)
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'MINUS))
'(MOVEI ADDI SUBI)
'(MOVNI SUBI ADDI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'BOTH))
'(ADD SUB IMUL IDIV FADR FSBR FDVR FMPR)
'(ADDB SUBB IMULB IDIVB FADRB FSBRB FDVRB FMPRB))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'FLOATI))
'(FADR FSBR FMPR FDVR MOVE)
'(FADRI FSBRI FMPRI FDVRI MOVSI))
(MAPC '(LAMBDA (X) (PUTPROP X 'NOTNUMP 'NOTNUMP)) ;NO SIDE-EFFECTS
'(NULL CONS XCONS APPEND *APPEND REVERSE MAKNAM EXPLODE EXPLODEC EXPLODEN COPYSYMBOL
TYPEP SYSP FIXP FLOATP BIGP NUMBERP ZEROP SIGNP ATOM ALPHALESSP BOUNDP PLIST
GETL GETCHAR LAST MEMBER MEMQ ASSOC ASSQ SUBLIS SUBST ARRAYDIMS LISTARRAY LISTIFY
EVALFRAME ERRFRAME SAMEPNAMEP PNGET BAKLIST PLUSP MINUSP HUNKP SYMBOLP))
(MAPC '(LAMBDA (X) (PUTPROP X 'EFFS 'NOTNUMP)) ;HAS SIDE-EFFECTS
'(NCONC *NCONC NREVERSE NRECONC INTERN READCH CURSORPOS
VALRET SUSPEND DELETE DELQ SASSOC SORT SORTCAR *ARRAY
*REARRAY REMOB *DELQ *DELETE
ASCII GENSYM SASSOC SASSQ SORT SORTCAR
FILLARRAY DUMPARRAYS LOADARRAYS TERPRI IMPLODE
REMPROP SETPLIST ALARMCLOCK SETSYNTAX))
(MAPC '(LAMBDA (X) (PUTPROP X T 'NOTNUMP)) ;SIDE-EFFECTS, AND RETURNS T
'(TYO DEPOSIT PRIN1 PRINC PRINT *TYO *PRIN1 *PRINC *PRINT))
(MAPC '(LAMBDA (DATA)
(MAPC '(LAMBDA (X) (AND (SYSP X) (PUTPROP X (CADAR DATA) (CAAR DATA))))
(CDR DATA)))
(APPEND (AND (STATUS FEATURE AI)
'( ((ACS 1) DISCOPY)
((ACS 2) MPX IMPX OMPX NEXTPLOT PLOT PLOTLIST PLOTTEXT
DISBLINK DISMARK DISET DISAPOINT
DISALINE DISLIST DISCRIBE DISGOBBLE )
((ACS 3) DISCREATE DISLINK DISFLUSH DISLOCATE DISCHANGE)
((ACS 4) DISMOTION)
((ACS 5) NVID NVSET NVFIX DISINI DISCUSS DISGORGE )))
(AND (STATUS FEATURE NEWIO)
'(((ACS 1) IN OUT CLOSE LINEL PAGEL CHARPOS LINENUM PAGENUM
CLEAR-INPUT CLEAR-OUTPUT FORCE-OUTPUT NAMELIST
TRUENAME PROBEF DLELTEF DEFAULTF FASLP)
((ACS 2) MERGEF)
((ACS 3) NAMESTRING SHORTNAMESTRING)
((ACS 4) RENAMEF ENDPAGEFN EOFFN FILEPOS)))
'(
((ACS 1) LENGTH LAST ADD1 SUB1 MINUS ABS FLOAT FIX
*TERPRI TERPRI *TYO TYO TYI 1+ 1- 1+/$ 1-/$
SLEEP RANDOM NOINTERRUPT EXAMINE
ARG MUNKAM ERRFRAME SIN COS SQRT LOG EXP ODDP)
((ACS 2) GET REMPROP MEMQ RECLAIM EQUAL DEPOSIT CURSORPOS
CONS NCONS XCONS SUBLIS NCONC *NCONC DELQ *DELQ
ASSQ ALARMCLOCK SETARG SETPLIST MAKNUM
SAMEPNAMEP ALPHALESSP GETCHARN MAKNAM LISTIFY)
((ACS 2) PLUS TIMES EXPT DIFFERENCE QUOTIENT MAX MIN
GREATERP LESSP ATAN
*PLUS *TIMES *GREAT *QUO *DIF *LESS
+ - // * +/$ -/$ ///$ */$ = < > /↑ /↑$ /\/\ /\
HAULONG HAIPART GCD BOOLE REMAINDER)
((ACS 3) GENSYM FLATSIZE FLATC PNGET EVALFRAME PURIFY
LISTARRAY FILLARRAY DUMPARRAYS ARRAYDIMS
PRINT PRIN1 PRINC *PRINT *PRIN1 *PRINC
SYSP COPYSYMBOL SXHASH
REVERSE NREVERSE NRECONC GETL PUTPROP ARGS)
((ACS 4) ASSOC SASSOC SASSQ CRUNIT)
((ACS 5) SUBST SUSPEND SETSYNTAX *DELETE DELETE MEMBER ALLOC *FUNCTION
*APPEND APPEND READCH *ARRAY *REARRAY ERRPRINT STATUS SSTATUS
PNPUT INTERN IMPLODE SORT SORTCAR REMOB ASCII ARRAYCALL
BAKTRACE BAKLIST LOADARRAYS GETMIDASOP GETDDTSYM PUTDDTSYM
UREAD UWRITE UKILL UFILE UPROBE UCLOSE UAPPEND
EXPLODEC EXPLODE EXPLODEN TYIPEEK))))
;PAGEBPORG, FASLOAD AREN'T HERE SINCE THEY SETQ BPORG
(MAPC '(LAMBDA (INST) (PUTPROP INST T 'P1BOOL1ABLE))
'(AND OR NULL NOT EQ = > < ZEROP PLUSP MINUSP COND MEMQ SIGNP))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NUMBERP 'P1BOOL1ABLE))
'(EQUAL GREATERP LESSP ODDP *GREAT *LESS))
(MAPC '(LAMBDA (INST INSTN)
(PUTPROP INST
(CONS (CONS 'TLNN INSTN) (CONS 'TLNE INSTN))
'P1BOOL1ABLE))
'(ATOM NUMBERP FIXP FLOATP BIGP HUNKP SYMBOLP)
'(175700 161400 121000 40400 20000 20 10000))
(MAPC '(LAMBDA (INST) (PUTPROP INST T 'CONTAGIOUS))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO))
(MAPC '(LAMBDA (INST) (PUTPROP INST T 'NUMBERP))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO
ABS MINUS FIX FLOAT IFIX ADD1 SUB1 REMAINDER HAULONG))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NOTYPE 'NUMBERP))
'(GREATERP LESSP *GREAT *LESS EQ EQUAL ODDP))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'ARITHP))
'( (/+ PLUS FIXNUM) (+$ PLUS FLONUM)
(/- DIFFERENCE FIXNUM) (-$ DIFFERENCE FLONUM)
(/* TIMES FIXNUM) (*$ TIMES FLONUM)
(/1+ ADD1 FIXNUM) (1+$ ADD1 FLONUM)
(/1- SUB1 FIXNUM) (1-$ SUB1 FLONUM)
(// QUOTIENT FIXNUM) (//$ QUOTIENT FLONUM)
(/> GREATERP NIL) (/< LESSP NIL)
(/\/\ GCD FIXNUM) (/\ REMAINDER FIXNUM)
(/= EQUAL NIL))))
(COMMENT FINAL CLEANUP)
(GCTWA)
(AND *PURE (SETQ PUTPROP GOBRKL))
(SETQ NORET NIL)
(DECLARE (EVAL (READ)) (READ))
(SETSYNTAX '/# 'MACRO NIL) ;FLUSHED AFTER COMPILATION
(PROG2 (SETQ CAR 'SYMBOL) (INITIALIZE MACRO)) ;FOR RUNNING INTERPRETIVELY ONLY
'COMPILER/ LOADED